Mercurial > hg > xemacs-beta
annotate tests/automated/lisp-tests.el @ 5595:391d809fa4e9
Update tests that have started failing because of changed design decisions.
2011-11-09 Aidan Kehoe <kehoea@parhasard.net>
Update some tests that have started failing because of some
changed design decisions.
* automated/lisp-tests.el (eq):
(type-of 42) now returns the symbol fixnum.
* automated/lisp-tests.el (needs-lexical-context):
(function ...) doesn't create a lexical context, and this is now the
case in interpreted as well as in compiled code.
* automated/mule-tests.el (featurep):
Silence messages when byte-compiling files; if a file doesn't have
the escape-quoted coding cookie, it will now have the
raw-text-unix coding cookie, look for that instead of looking for
the absence of the escape-quoted coding cookie.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Wed, 09 Nov 2011 13:16:19 +0000 |
| parents | 071b810ceb18 |
| children | 5bda701e9e7c |
| 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 -*- |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2 ;; Copyright (C) 2010 Ben Wing. |
| 428 | 3 |
| 4 ;; Author: Martin Buchholz <martin@xemacs.org> | |
| 5 ;; Maintainer: Martin Buchholz <martin@xemacs.org> | |
| 6 ;; Created: 1998 | |
| 7 ;; Keywords: tests | |
| 8 | |
| 9 ;; This file is part of XEmacs. | |
| 10 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5244
diff
changeset
|
11 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5244
diff
changeset
|
12 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5244
diff
changeset
|
13 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5244
diff
changeset
|
14 ;; option) any later version. |
| 428 | 15 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5244
diff
changeset
|
16 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5244
diff
changeset
|
17 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5244
diff
changeset
|
18 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5244
diff
changeset
|
19 ;; for more details. |
| 428 | 20 |
| 21 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5244
diff
changeset
|
22 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 428 | 23 |
| 24 ;;; Synched up with: Not in FSF. | |
| 25 | |
| 26 ;;; Commentary: | |
| 27 | |
| 28 ;;; Test basic Lisp engine functionality | |
| 29 ;;; See test-harness.el for instructions on how to run these tests. | |
| 30 | |
| 31 (eval-when-compile | |
| 32 (condition-case nil | |
| 33 (require 'test-harness) | |
| 34 (file-error | |
| 35 (push "." load-path) | |
| 36 (when (and (boundp 'load-file-name) (stringp load-file-name)) | |
| 37 (push (file-name-directory load-file-name) load-path)) | |
| 38 (require 'test-harness)))) | |
| 39 | |
| 40 (Check-Error wrong-number-of-arguments (setq setq-test-foo)) | |
| 41 (Check-Error wrong-number-of-arguments (setq setq-test-foo 1 setq-test-bar)) | |
| 42 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo)) | |
| 43 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo 1 setq-test-bar)) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
44 (Assert (eq (setq) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
45 (Assert (eq (setq-default) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
46 (Assert (eq (setq setq-test-foo 42) 42)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
47 (Assert (eq (setq-default setq-test-foo 42) 42)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
48 (Assert (eq (setq setq-test-foo 42 setq-test-bar 99) 99)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
49 (Assert (eq (setq-default setq-test-foo 42 setq-test-bar 99) 99)) |
| 428 | 50 |
| 51 (macrolet ((test-setq (expected-result &rest body) | |
| 52 `(progn | |
| 53 (defun test-setq-fun () ,@body) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
54 (Assert (eq ,expected-result (test-setq-fun))) |
| 428 | 55 (byte-compile 'test-setq-fun) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
56 (Assert (eq ,expected-result (test-setq-fun)))))) |
| 428 | 57 (test-setq nil (setq)) |
| 58 (test-setq nil (setq-default)) | |
| 59 (test-setq 42 (setq test-setq-var 42)) | |
| 60 (test-setq 42 (setq-default test-setq-var 42)) | |
| 61 (test-setq 42 (setq test-setq-bar 99 test-setq-var 42)) | |
| 62 (test-setq 42 (setq-default test-setq-bar 99 test-setq-var 42)) | |
| 63 ) | |
| 64 | |
| 65 (let ((my-vector [1 2 3 4]) | |
| 66 (my-bit-vector (bit-vector 1 0 1 0)) | |
| 67 (my-string "1234") | |
| 68 (my-list '(1 2 3 4))) | |
| 69 | |
| 70 ;;(Assert (fooooo)) ;; Generate Other failure | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
71 ;;(Assert (eq 1 2)) ;; Generate Assertion failure |
| 428 | 72 |
| 73 (dolist (sequence (list my-vector my-bit-vector my-string my-list)) | |
| 74 (Assert (sequencep sequence)) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
75 (Assert (eq 4 (length sequence)))) |
| 428 | 76 |
| 77 (dolist (array (list my-vector my-bit-vector my-string)) | |
| 78 (Assert (arrayp array))) | |
| 79 | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
80 (Assert (eq (elt my-vector 0) 1)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
81 (Assert (eq (elt my-bit-vector 0) 1)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
82 (Assert (eq (elt my-string 0) ?1)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
83 (Assert (eq (elt my-list 0) 1)) |
| 428 | 84 |
| 85 (fillarray my-vector 5) | |
| 86 (fillarray my-bit-vector 1) | |
| 87 (fillarray my-string ?5) | |
| 88 | |
| 89 (dolist (array (list my-vector my-bit-vector)) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
90 (Assert (eq 4 (length array)))) |
| 428 | 91 |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
92 (Assert (eq (elt my-vector 0) 5)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
93 (Assert (eq (elt my-bit-vector 0) 1)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
94 (Assert (eq (elt my-string 0) ?5)) |
| 428 | 95 |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
96 (Assert (eq (elt my-vector 3) 5)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
97 (Assert (eq (elt my-bit-vector 3) 1)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
98 (Assert (eq (elt my-string 3) ?5)) |
| 428 | 99 |
| 100 (fillarray my-bit-vector 0) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
101 (Assert (eq 4 (length my-bit-vector))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
102 (Assert (eq (elt my-bit-vector 2) 0)) |
| 428 | 103 ) |
| 104 | |
| 105 (defun make-circular-list (length) | |
| 106 "Create evil emacs-crashing circular list of length LENGTH" | |
| 107 (let ((circular-list | |
| 108 (make-list | |
| 109 length | |
| 110 'you-are-trapped-in-a-twisty-maze-of-cons-cells-all-alike))) | |
| 111 (setcdr (last circular-list) circular-list) | |
| 112 circular-list)) | |
| 113 | |
| 114 ;;----------------------------------------------------- | |
| 115 ;; Test `nconc' | |
| 116 ;;----------------------------------------------------- | |
| 117 (defun make-list-012 () (list 0 1 2)) | |
| 118 | |
| 119 (Check-Error wrong-type-argument (nconc 'foo nil)) | |
| 120 | |
| 121 (dolist (length '(1 2 3 4 1000 2000)) | |
| 122 (Check-Error circular-list (nconc (make-circular-list length) 'foo)) | |
| 123 (Check-Error circular-list (nconc '(1 . 2) (make-circular-list length) 'foo)) | |
| 124 (Check-Error circular-list (nconc '(1 . 2) '(3 . 4) (make-circular-list length) 'foo))) | |
| 125 | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
126 (Assert (eq (nconc) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
127 (Assert (eq (nconc nil) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
128 (Assert (eq (nconc nil nil) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
129 (Assert (eq (nconc nil nil nil) nil)) |
| 428 | 130 |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
131 (let ((x (make-list-012))) (Assert (eq (nconc nil x) x))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
132 (let ((x (make-list-012))) (Assert (eq (nconc x nil) x))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
133 (let ((x (make-list-012))) (Assert (eq (nconc nil x nil) x))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
134 (let ((x (make-list-012))) (Assert (eq (nconc x) x))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
135 (let ((x (make-list-012))) (Assert (eq (nconc x (make-circular-list 3)) x))) |
| 428 | 136 |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
137 (Assert (equal (nconc '(1 . 2) '(3 . 4) '(5 . 6)) '(1 3 5 . 6))) |
| 428 | 138 |
| 139 (let ((y (nconc (make-list-012) nil (list 3 4 5) nil))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
140 (Assert (eq (length y) 6)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
141 (Assert (eq (nth 3 y) 3))) |
| 428 | 142 |
| 143 ;;----------------------------------------------------- | |
| 144 ;; Test `last' | |
| 145 ;;----------------------------------------------------- | |
| 146 (Check-Error wrong-type-argument (last 'foo)) | |
| 147 (Check-Error wrong-number-of-arguments (last)) | |
| 148 (Check-Error wrong-number-of-arguments (last '(1 2) 1 1)) | |
| 149 (Check-Error circular-list (last (make-circular-list 1))) | |
| 150 (Check-Error circular-list (last (make-circular-list 2000))) | |
| 151 (let ((x (list 0 1 2 3))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
152 (Assert (eq (last nil) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
153 (Assert (eq (last x 0) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
154 (Assert (eq (last x ) (cdddr x))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
155 (Assert (eq (last x 1) (cdddr x))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
156 (Assert (eq (last x 2) (cddr x))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
157 (Assert (eq (last x 3) (cdr x))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
158 (Assert (eq (last x 4) x)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
159 (Assert (eq (last x 9) x)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
160 (Assert (eq (last '(1 . 2) 0) 2)) |
| 428 | 161 ) |
| 162 | |
| 163 ;;----------------------------------------------------- | |
| 164 ;; Test `butlast' and `nbutlast' | |
| 165 ;;----------------------------------------------------- | |
| 166 (Check-Error wrong-type-argument (butlast 'foo)) | |
| 167 (Check-Error wrong-type-argument (nbutlast 'foo)) | |
| 168 (Check-Error wrong-number-of-arguments (butlast)) | |
| 169 (Check-Error wrong-number-of-arguments (nbutlast)) | |
| 170 (Check-Error wrong-number-of-arguments (butlast '(1 2) 1 1)) | |
| 171 (Check-Error wrong-number-of-arguments (nbutlast '(1 2) 1 1)) | |
| 172 (Check-Error circular-list (butlast (make-circular-list 1))) | |
| 173 (Check-Error circular-list (nbutlast (make-circular-list 1))) | |
| 174 (Check-Error circular-list (butlast (make-circular-list 2000))) | |
| 175 (Check-Error circular-list (nbutlast (make-circular-list 2000))) | |
| 176 | |
| 177 (let* ((x (list 0 1 2 3)) | |
| 178 (y (butlast x)) | |
| 179 (z (nbutlast x))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
180 (Assert (eq z x)) |
| 428 | 181 (Assert (not (eq y x))) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
182 (Assert (equal y '(0 1 2))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
183 (Assert (equal z y))) |
| 428 | 184 |
| 185 (let* ((x (list 0 1 2 3 4)) | |
| 186 (y (butlast x 2)) | |
| 187 (z (nbutlast x 2))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
188 (Assert (eq z x)) |
| 428 | 189 (Assert (not (eq y x))) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
190 (Assert (equal y '(0 1 2))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
191 (Assert (equal z y))) |
| 428 | 192 |
| 193 (let* ((x (list 0 1 2 3)) | |
| 194 (y (butlast x 0)) | |
| 195 (z (nbutlast x 0))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
196 (Assert (eq z x)) |
| 428 | 197 (Assert (not (eq y x))) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
198 (Assert (equal y '(0 1 2 3))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
199 (Assert (equal z y))) |
| 428 | 200 |
|
5285
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
201 (let* ((x (list* 0 1 2 3 4 5 6.0 ?7 ?8 (vector 'a 'b 'c))) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
202 (y (butlast x 0)) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
203 (z (nbutlast x 0))) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
204 (Assert (eq z x)) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
205 (Assert (not (eq y x))) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
206 (Assert (equal y '(0 1 2 3 4 5 6.0 ?7 ?8))) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
207 (Assert (equal z y))) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
208 |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
209 (Assert (eq (butlast '(x)) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
210 (Assert (eq (nbutlast '(x)) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
211 (Assert (eq (butlast '()) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
212 (Assert (eq (nbutlast '()) nil)) |
| 428 | 213 |
|
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
214 (when (featurep 'bignum) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
215 (let* ((x (list* 0 1 2 3 4 5 6.0 ?7 ?8 (vector 'a 'b 'c))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
216 (y (butlast x (* 2 most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
217 (z (nbutlast x (* 3 most-positive-fixnum)))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
218 (Assert (eq nil y) "checking butlast with a large bignum gives nil") |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
219 (Assert (eq nil z) "checking nbutlast with a large bignum gives nil") |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
220 (Check-Error wrong-type-argument |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
221 (nbutlast x (1- most-negative-fixnum)) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
222 "checking nbutlast with a negative bignum errors"))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
223 |
| 428 | 224 ;;----------------------------------------------------- |
| 225 ;; Test `copy-list' | |
| 226 ;;----------------------------------------------------- | |
| 227 (Check-Error wrong-type-argument (copy-list 'foo)) | |
| 228 (Check-Error wrong-number-of-arguments (copy-list)) | |
| 229 (Check-Error wrong-number-of-arguments (copy-list '(1 2) 1)) | |
| 230 (Check-Error circular-list (copy-list (make-circular-list 1))) | |
| 231 (Check-Error circular-list (copy-list (make-circular-list 2000))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
232 (Assert (eq '() (copy-list '()))) |
| 428 | 233 (dolist (x '((1) (1 2) (1 2 3) (1 2 . 3))) |
| 234 (let ((y (copy-list x))) | |
| 235 (Assert (and (equal x y) (not (eq x y)))))) | |
| 236 | |
| 237 ;;----------------------------------------------------- | |
|
5285
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
238 ;; Test `ldiff' |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
239 ;;----------------------------------------------------- |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
240 (Check-Error wrong-type-argument (ldiff 'foo pi)) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
241 (Check-Error wrong-number-of-arguments (ldiff)) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
242 (Check-Error wrong-number-of-arguments (ldiff '(1 2))) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
243 (Check-Error circular-list (ldiff (make-circular-list 1) nil)) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
244 (Check-Error circular-list (ldiff (make-circular-list 2000) nil)) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
245 (Assert (eq '() (ldiff '() pi))) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
246 (dolist (x '((1) (1 2) (1 2 3) (1 2 . 3))) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
247 (let ((y (ldiff x nil))) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
248 (Assert (and (equal x y) (not (eq x y)))))) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
249 |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
250 (let* ((vector (vector 'foo)) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
251 (dotted `(1 2 3 ,pi 40 50 . ,vector)) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
252 (dotted-pi `(1 2 3 . ,pi)) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
253 without-vector without-pi) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
254 (Assert (equal dotted (ldiff dotted nil)) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
255 "checking ldiff handles dotted lists properly") |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
256 (Assert (equal (butlast dotted 0) (ldiff dotted vector)) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
257 "checking ldiff discards dotted elements correctly") |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
258 (Assert (equal (butlast dotted-pi 0) (ldiff dotted-pi (* 4 (atan 1)))) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
259 "checking ldiff handles float equivalence correctly")) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
260 |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
261 ;;----------------------------------------------------- |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
262 ;; Test `tailp' |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
263 ;;----------------------------------------------------- |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
264 (Check-Error wrong-type-argument (tailp pi 'foo)) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
265 (Check-Error wrong-number-of-arguments (tailp)) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
266 (Check-Error wrong-number-of-arguments (tailp '(1 2))) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
267 (Check-Error circular-list (tailp nil (make-circular-list 1))) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
268 (Check-Error circular-list (tailp nil (make-circular-list 2000))) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
269 (Assert (null (tailp pi '())) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
270 "checking pi is not a tail of the list nil") |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
271 (Assert (tailp 3 '(1 2 . 3)) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
272 "checking #'tailp works with a dotted integer.") |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
273 (Assert (tailp pi `(1 2 . ,(* 4 (atan 1)))) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
274 "checking tailp works with non-eq dotted floats.") |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
275 (let ((list (make-list 2048 nil))) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
276 (Assert (tailp (nthcdr 2000 list) (nconc list list)) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
277 "checking #'tailp succeeds with circular LIST containing SUBLIST")) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
278 |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
279 ;;----------------------------------------------------- |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
280 ;; Test `endp' |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
281 ;;----------------------------------------------------- |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
282 (Check-Error wrong-type-argument (endp 'foo)) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
283 (Check-Error wrong-number-of-arguments (endp)) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
284 (Check-Error wrong-number-of-arguments (endp '(1 2) 'foo)) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
285 (Assert (endp nil) "checking nil is recognized as the end of a list") |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
286 (Assert (not (endp (list 200 200 4 0 9))) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
287 "checking a cons is not recognised as the end of a list") |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
288 |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
289 ;;----------------------------------------------------- |
| 428 | 290 ;; Arithmetic operations |
| 291 ;;----------------------------------------------------- | |
| 292 | |
| 293 ;; Test `+' | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
294 (Assert (eq (+ 1 1) 2)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
295 (Assert (= (+ 1.0 1.0) 2.0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
296 (Assert (= (+ 1.0 3.0 0.0) 4.0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
297 (Assert (= (+ 1 1.0) 2.0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
298 (Assert (= (+ 1.0 1) 2.0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
299 (Assert (= (+ 1.0 1 1) 3.0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
300 (Assert (= (+ 1 1 1.0) 3.0)) |
| 1983 | 301 (if (featurep 'bignum) |
| 302 (progn | |
| 303 (Assert (bignump (1+ most-positive-fixnum))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
304 (Assert (eq most-positive-fixnum (1- (1+ most-positive-fixnum)))) |
| 1983 | 305 (Assert (bignump (+ most-positive-fixnum 1))) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
306 (Assert (eq most-positive-fixnum (- (+ most-positive-fixnum 1) 1))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
307 (Assert (= (1+ most-positive-fixnum) (- most-negative-fixnum))) |
| 1983 | 308 (Assert (zerop (+ (* 3 most-negative-fixnum) (* 3 most-positive-fixnum) |
| 309 3)))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
310 (Assert (eq (1+ most-positive-fixnum) most-negative-fixnum)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
311 (Assert (eq (+ most-positive-fixnum 1) most-negative-fixnum))) |
| 1983 | 312 |
| 313 (when (featurep 'ratio) | |
| 314 (let ((threefourths (read "3/4")) | |
| 315 (threehalfs (read "3/2")) | |
| 316 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum))) | |
| 317 (bigneg (div (+ most-positive-fixnum 2) most-negative-fixnum)) | |
| 318 (negone (div (1+ most-positive-fixnum) most-negative-fixnum))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
319 (Assert (= negone -1)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
320 (Assert (= threehalfs (+ threefourths threefourths))) |
| 1983 | 321 (Assert (zerop (+ bigpos bigneg))))) |
| 428 | 322 |
| 323 ;; Test `-' | |
| 324 (Check-Error wrong-number-of-arguments (-)) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
325 (Assert (eq (- 0) 0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
326 (Assert (eq (- 1) -1)) |
| 428 | 327 (dolist (one `(1 1.0 ?\1 ,(Int-to-Marker 1))) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
328 (Assert (= (+ 1 one) 2)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
329 (Assert (= (+ one) 1)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
330 (Assert (= (+ one) one)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
331 (Assert (= (- one) -1)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
332 (Assert (= (- one one) 0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
333 (Assert (= (- one one one) -1)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
334 (Assert (= (- 0 one) -1)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
335 (Assert (= (- 0 one one) -2)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
336 (Assert (= (+ one 1) 2)) |
| 428 | 337 (dolist (zero '(0 0.0 ?\0)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
338 (Assert (= (+ 1 zero) 1) zero) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
339 (Assert (= (+ zero 1) 1) zero) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
340 (Assert (= (- zero) zero) zero) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
341 (Assert (= (- zero) 0) zero) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
342 (Assert (= (- zero zero) 0) zero) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
343 (Assert (= (- zero one one) -2) zero))) |
| 428 | 344 |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
345 (Assert (= (- 1.5 1) .5)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
346 (Assert (= (- 1 1.5) (- .5))) |
| 428 | 347 |
| 1983 | 348 (if (featurep 'bignum) |
| 349 (progn | |
| 350 (Assert (bignump (1- most-negative-fixnum))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
351 (Assert (eq most-negative-fixnum (1+ (1- most-negative-fixnum)))) |
| 1983 | 352 (Assert (bignump (- most-negative-fixnum 1))) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
353 (Assert (eq most-negative-fixnum (+ (- most-negative-fixnum 1) 1))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
354 (Assert (= (1- most-negative-fixnum) (- 0 most-positive-fixnum 2))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
355 (Assert (eq (- (- most-positive-fixnum most-negative-fixnum) |
| 1983 | 356 (* 2 most-positive-fixnum)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
357 1))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
358 (Assert (eq (1- most-negative-fixnum) most-positive-fixnum)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
359 (Assert (eq (- most-negative-fixnum 1) most-positive-fixnum))) |
| 1983 | 360 |
| 361 (when (featurep 'ratio) | |
| 362 (let ((threefourths (read "3/4")) | |
| 363 (threehalfs (read "3/2")) | |
| 364 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum))) | |
| 365 (bigneg (div most-positive-fixnum most-negative-fixnum)) | |
| 366 (negone (div (1+ most-positive-fixnum) most-negative-fixnum))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
367 (Assert (= (- negone) 1)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
368 (Assert (= threefourths (- threehalfs threefourths))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
369 (Assert (= (- bigpos bigneg) 2)))) |
| 428 | 370 |
| 371 ;; Test `/' | |
| 372 | |
| 373 ;; Test division by zero errors | |
| 374 (dolist (zero '(0 0.0 ?\0)) | |
| 375 (Check-Error arith-error (/ zero)) | |
| 376 (dolist (n1 `(42 42.0 ?\042 ,(Int-to-Marker 42))) | |
| 377 (Check-Error arith-error (/ n1 zero)) | |
| 378 (dolist (n2 `(3 3.0 ?\03 ,(Int-to-Marker 3))) | |
| 379 (Check-Error arith-error (/ n1 n2 zero))))) | |
| 380 | |
| 381 ;; Other tests for `/' | |
| 382 (Check-Error wrong-number-of-arguments (/)) | |
| 383 (let (x) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
384 (Assert (= (/ (setq x 2)) 0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
385 (Assert (= (/ (setq x 2.0)) 0.5))) |
| 428 | 386 |
| 387 (dolist (six '(6 6.0 ?\06)) | |
| 388 (dolist (two '(2 2.0 ?\02)) | |
| 389 (dolist (three '(3 3.0 ?\03)) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
390 (Assert (= (/ six two) three) (list six two three))))) |
| 428 | 391 |
| 392 (dolist (three '(3 3.0 ?\03)) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
393 (Assert (= (/ three 2.0) 1.5) three)) |
| 428 | 394 (dolist (two '(2 2.0 ?\02)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
395 (Assert (= (/ 3.0 two) 1.5) two)) |
| 428 | 396 |
| 1983 | 397 (when (featurep 'bignum) |
| 398 (let* ((million 1000000) | |
| 399 (billion (* million 1000)) ;; American, not British, billion | |
| 400 (trillion (* billion 1000))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
401 (Assert (= (/ billion 1000) (/ trillion million) million 1000000.0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
402 (Assert (= (/ billion -1000) (/ trillion (- million)) (- million))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
403 (Assert (= (/ trillion 1000) billion 1000000000.0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
404 (Assert (= (/ trillion -1000) (- billion) -1000000000.0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
405 (Assert (= (/ trillion 10) (* 100 billion) 100000000000.0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
406 (Assert (= (/ (- trillion) 10) (* -100 billion) -100000000000.0)))) |
| 1983 | 407 |
| 408 (when (featurep 'ratio) | |
| 409 (let ((half (div 1 2)) | |
| 410 (fivefourths (div 5 4)) | |
| 411 (fivehalfs (div 5 2))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
412 (Assert (= half (read "3000000000/6000000000"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
413 (Assert (= (/ fivehalfs fivefourths) 2)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
414 (Assert (= (/ fivefourths fivehalfs) half)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
415 (Assert (= (- half) (read "-3000000000/6000000000"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
416 (Assert (= (/ fivehalfs (- fivefourths)) -2)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
417 (Assert (= (/ (- fivefourths) fivehalfs) (- half))))) |
| 1983 | 418 |
| 428 | 419 ;; Test `*' |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
420 (Assert (= 1 (*))) |
| 428 | 421 |
| 422 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
423 (Assert (= 1 (* one)) one)) |
| 428 | 424 |
| 425 (dolist (two '(2 2.0 ?\02)) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
426 (Assert (= 2 (* two)) two)) |
| 428 | 427 |
| 428 (dolist (six '(6 6.0 ?\06)) | |
| 429 (dolist (two '(2 2.0 ?\02)) | |
| 430 (dolist (three '(3 3.0 ?\03)) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
431 (Assert (= (* three two) six) (list three two six))))) |
| 428 | 432 |
| 433 (dolist (three '(3 3.0 ?\03)) | |
| 434 (dolist (two '(2 2.0 ?\02)) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
435 (Assert (= (* 1.5 two) three) (list two three)) |
| 428 | 436 (dolist (five '(5 5.0 ?\05)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
437 (Assert (= 30 (* five two three)) (list five two three))))) |
| 428 | 438 |
| 1983 | 439 (when (featurep 'bignum) |
| 440 (let ((64K 65536)) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
441 (Assert (= (* 64K 64K) (read "4294967296"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
442 (Assert (= (* (- 64K) 64K) (read "-4294967296"))) |
| 1983 | 443 (Assert (/= (* -1 most-negative-fixnum) most-negative-fixnum)))) |
| 444 | |
| 445 (when (featurep 'ratio) | |
| 446 (let ((half (div 1 2)) | |
| 447 (fivefourths (div 5 4)) | |
| 448 (twofifths (div 2 5))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
449 (Assert (= (* fivefourths twofifths) half)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
450 (Assert (= (* half twofifths) (read "3/15"))))) |
| 1983 | 451 |
| 428 | 452 ;; Test `+' |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
453 (Assert (= 0 (+))) |
| 428 | 454 |
| 455 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
456 (Assert (= 1 (+ one)) one)) |
| 428 | 457 |
| 458 (dolist (two '(2 2.0 ?\02)) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
459 (Assert (= 2 (+ two)) two)) |
| 428 | 460 |
| 461 (dolist (five '(5 5.0 ?\05)) | |
| 462 (dolist (two '(2 2.0 ?\02)) | |
| 463 (dolist (three '(3 3.0 ?\03)) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
464 (Assert (= (+ three two) five) (list three two five)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
465 (Assert (= 10 (+ five two three)) (list five two three))))) |
| 428 | 466 |
| 467 ;; Test `max', `min' | |
| 468 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
469 (Assert (= one (max one)) one) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
470 (Assert (= one (max one one)) one) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
471 (Assert (= one (max one one one)) one) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
472 (Assert (= one (min one)) one) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
473 (Assert (= one (min one one)) one) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
474 (Assert (= one (min one one one)) one) |
| 428 | 475 (dolist (two `(2 2.0 ?\02 ,(Int-to-Marker 2))) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
476 (Assert (= one (min one two)) (list one two)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
477 (Assert (= one (min one two two)) (list one two)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
478 (Assert (= one (min two two one)) (list one two)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
479 (Assert (= two (max one two)) (list one two)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
480 (Assert (= two (max one two two)) (list one two)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
481 (Assert (= two (max two two one)) (list one two)))) |
| 428 | 482 |
| 1983 | 483 (when (featurep 'bignum) |
| 484 (let ((big (1+ most-positive-fixnum)) | |
| 485 (small (1- most-negative-fixnum))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
486 (Assert (= big (max 1 1000000.0 most-positive-fixnum big))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
487 (Assert (= small (min -1 -1000000.0 most-negative-fixnum small))))) |
| 1983 | 488 |
| 489 (when (featurep 'ratio) | |
| 490 (let* ((big (1+ most-positive-fixnum)) | |
| 491 (small (1- most-negative-fixnum)) | |
| 492 (bigr (div (* 5 (1+ most-positive-fixnum)) 4)) | |
| 493 (smallr (- bigr))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
494 (Assert (= bigr (max 1 1000000.0 most-positive-fixnum big bigr))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
495 (Assert (= smallr (min -1 -1000000.0 most-negative-fixnum small smallr))))) |
| 1983 | 496 |
| 446 | 497 ;; The byte compiler has special handling for these constructs: |
| 498 (let ((three 3) (five 5)) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
499 (Assert (= (+ three five 1) 9)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
500 (Assert (= (+ 1 three five) 9)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
501 (Assert (= (+ three five -1) 7)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
502 (Assert (= (+ -1 three five) 7)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
503 (Assert (= (+ three 1) 4)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
504 (Assert (= (+ three -1) 2)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
505 (Assert (= (+ -1 three) 2)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
506 (Assert (= (+ -1 three) 2)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
507 (Assert (= (- three five 1) -3)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
508 (Assert (= (- 1 three five) -7)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
509 (Assert (= (- three five -1) -1)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
510 (Assert (= (- -1 three five) -9)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
511 (Assert (= (- three 1) 2)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
512 (Assert (= (- three 2 1) 0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
513 (Assert (= (- 2 three 1) -2)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
514 (Assert (= (- three -1) 4)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
515 (Assert (= (- three 0) 3)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
516 (Assert (= (- three 0 five) -2)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
517 (Assert (= (- 0 three 0 five) -8)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
518 (Assert (= (- 0 three five) -8)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
519 (Assert (= (* three 2) 6)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
520 (Assert (= (* three -1 five) -15)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
521 (Assert (= (* three 1 five) 15)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
522 (Assert (= (* three 0 five) 0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
523 (Assert (= (* three 2 five) 30)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
524 (Assert (= (/ three 1) 3)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
525 (Assert (= (/ three -1) -3)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
526 (Assert (= (/ (* five five) 2 2) 6)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
527 (Assert (= (/ 64 five 2) 6))) |
| 446 | 528 |
| 529 | |
| 428 | 530 ;;----------------------------------------------------- |
| 531 ;; Logical bit-twiddling operations | |
| 532 ;;----------------------------------------------------- | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
533 (Assert (= (logxor) 0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
534 (Assert (= (logior) 0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
535 (Assert (= (logand) -1)) |
| 428 | 536 |
| 537 (Check-Error wrong-type-argument (logxor 3.0)) | |
| 538 (Check-Error wrong-type-argument (logior 3.0)) | |
| 539 (Check-Error wrong-type-argument (logand 3.0)) | |
| 540 | |
| 541 (dolist (three '(3 ?\03)) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
542 (Assert (eq 3 (logand three)) three) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
543 (Assert (eq 3 (logxor three)) three) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
544 (Assert (eq 3 (logior three)) three) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
545 (Assert (eq 3 (logand three three)) three) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
546 (Assert (eq 0 (logxor three three)) three) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
547 (Assert (eq 3 (logior three three))) three) |
| 428 | 548 |
| 549 (dolist (one `(1 ?\01 ,(Int-to-Marker 1))) | |
| 550 (dolist (two '(2 ?\02)) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
551 (Assert (eq 0 (logand one two)) (list one two)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
552 (Assert (eq 3 (logior one two)) (list one two)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
553 (Assert (eq 3 (logxor one two)) (list one two))) |
| 428 | 554 (dolist (three '(3 ?\03)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
555 (Assert (eq 1 (logand one three)) (list one three)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
556 (Assert (eq 3 (logior one three)) (list one three)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
557 (Assert (eq 2 (logxor one three)) (list one three)))) |
| 428 | 558 |
| 559 ;;----------------------------------------------------- | |
| 560 ;; Test `%', mod | |
| 561 ;;----------------------------------------------------- | |
| 562 (Check-Error wrong-number-of-arguments (%)) | |
| 563 (Check-Error wrong-number-of-arguments (% 1)) | |
| 564 (Check-Error wrong-number-of-arguments (% 1 2 3)) | |
| 565 | |
| 566 (Check-Error wrong-number-of-arguments (mod)) | |
| 567 (Check-Error wrong-number-of-arguments (mod 1)) | |
| 568 (Check-Error wrong-number-of-arguments (mod 1 2 3)) | |
| 569 | |
| 570 (Check-Error wrong-type-argument (% 10.0 2)) | |
| 571 (Check-Error wrong-type-argument (% 10 2.0)) | |
| 572 | |
|
5576
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
573 (labels ((test1 (x) (Assert (eql x (+ (% x 17) (* (/ x 17) 17))) x)) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
574 (test2 (x) (Assert (eql (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17))) x)) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
575 (test3 (x) (Assert (eql x (+ (% (- x) 17) (* (/ (- x) 17) 17))) x)) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
576 (test4 (x) (Assert (eql (% x -17) (- (% (- x) 17))) x)) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
577 (test5 (x) (Assert (eql (% x -17) (% (- x) 17))) x)) |
| 2056 | 578 (test1 most-negative-fixnum) |
| 579 (if (featurep 'bignum) | |
| 2075 | 580 (progn |
| 581 (test2 most-negative-fixnum) | |
| 582 (test4 most-negative-fixnum)) | |
| 583 (test3 most-negative-fixnum) | |
| 584 (test5 most-negative-fixnum)) | |
| 2056 | 585 (test1 most-positive-fixnum) |
| 586 (test2 most-positive-fixnum) | |
| 587 (test4 most-positive-fixnum) | |
| 588 (dotimes (j 30) | |
| 589 (let ((x (random))) | |
| 590 (if (eq x most-negative-fixnum) (setq x (1+ x))) | |
| 591 (if (eq x most-positive-fixnum) (setq x (1- x))) | |
| 592 (test1 x) | |
| 593 (test2 x) | |
| 594 (test4 x)))) | |
| 428 | 595 |
| 596 (macrolet | |
| 597 ((division-test (seven) | |
| 598 `(progn | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
599 (Assert (eq (% ,seven 2) 1)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
600 (Assert (eq (% ,seven -2) 1)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
601 (Assert (eq (% (- ,seven) 2) -1)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
602 (Assert (eq (% (- ,seven) -2) -1)) |
| 428 | 603 |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
604 (Assert (eq (% ,seven 4) 3)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
605 (Assert (eq (% ,seven -4) 3)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
606 (Assert (eq (% (- ,seven) 4) -3)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
607 (Assert (eq (% (- ,seven) -4) -3)) |
| 428 | 608 |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
609 (Assert (eq (% 35 ,seven) 0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
610 (Assert (eq (% -35 ,seven) 0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
611 (Assert (eq (% 35 (- ,seven)) 0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
612 (Assert (eq (% -35 (- ,seven)) 0)) |
| 428 | 613 |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
614 (Assert (eq (mod ,seven 2) 1)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
615 (Assert (eq (mod ,seven -2) -1)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
616 (Assert (eq (mod (- ,seven) 2) 1)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
617 (Assert (eq (mod (- ,seven) -2) -1)) |
| 428 | 618 |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
619 (Assert (eq (mod ,seven 4) 3)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
620 (Assert (eq (mod ,seven -4) -1)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
621 (Assert (eq (mod (- ,seven) 4) 1)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
622 (Assert (eq (mod (- ,seven) -4) -3)) |
| 428 | 623 |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
624 (Assert (eq (mod 35 ,seven) 0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
625 (Assert (eq (mod -35 ,seven) 0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
626 (Assert (eq (mod 35 (- ,seven)) 0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
627 (Assert (eq (mod -35 (- ,seven)) 0)) |
| 428 | 628 |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
629 (Assert (= (mod ,seven 2.0) 1.0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
630 (Assert (= (mod ,seven -2.0) -1.0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
631 (Assert (= (mod (- ,seven) 2.0) 1.0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
632 (Assert (= (mod (- ,seven) -2.0) -1.0)) |
| 428 | 633 |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
634 (Assert (= (mod ,seven 4.0) 3.0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
635 (Assert (= (mod ,seven -4.0) -1.0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
636 (Assert (= (mod (- ,seven) 4.0) 1.0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
637 (Assert (= (mod (- ,seven) -4.0) -3.0)) |
| 428 | 638 |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
639 (Assert (eq (% 0 ,seven) 0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
640 (Assert (eq (% 0 (- ,seven)) 0)) |
| 428 | 641 |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
642 (Assert (eq (mod 0 ,seven) 0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
643 (Assert (eq (mod 0 (- ,seven)) 0)) |
| 428 | 644 |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
645 (Assert (= (mod 0.0 ,seven) 0.0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
646 (Assert (= (mod 0.0 (- ,seven)) 0.0))))) |
| 428 | 647 |
| 648 (division-test 7) | |
| 649 (division-test ?\07) | |
| 650 (division-test (Int-to-Marker 7))) | |
| 651 | |
| 1983 | 652 (when (featurep 'bignum) |
| 653 (let ((big (+ (* 7 most-positive-fixnum 6))) | |
| 654 (negbig (- (* 7 most-negative-fixnum 6)))) | |
| 655 (= (% big (1+ most-positive-fixnum)) most-positive-fixnum) | |
| 656 (= (% negbig (1- most-negative-fixnum)) most-negative-fixnum) | |
| 657 (= (mod big (1+ most-positive-fixnum)) most-positive-fixnum) | |
| 658 (= (mod negbig (1- most-negative-fixnum)) most-negative-fixnum))) | |
| 428 | 659 |
| 660 ;;----------------------------------------------------- | |
| 661 ;; Arithmetic comparison operations | |
| 662 ;;----------------------------------------------------- | |
| 663 (Check-Error wrong-number-of-arguments (=)) | |
| 664 (Check-Error wrong-number-of-arguments (<)) | |
| 665 (Check-Error wrong-number-of-arguments (>)) | |
| 666 (Check-Error wrong-number-of-arguments (<=)) | |
| 667 (Check-Error wrong-number-of-arguments (>=)) | |
| 668 (Check-Error wrong-number-of-arguments (/=)) | |
| 669 | |
| 670 ;; One argument always yields t | |
| 671 (loop for x in `(1 1.0 ,(Int-to-Marker 1) ?z) do | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
672 (Assert (eq t (= x)) x) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
673 (Assert (eq t (< x)) x) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
674 (Assert (eq t (> x)) x) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
675 (Assert (eq t (>= x)) x) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
676 (Assert (eq t (<= x)) x) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
677 (Assert (eq t (/= x)) x) |
| 428 | 678 ) |
| 679 | |
| 680 ;; Type checking | |
| 681 (Check-Error wrong-type-argument (= 'foo 1)) | |
| 682 (Check-Error wrong-type-argument (<= 'foo 1)) | |
| 683 (Check-Error wrong-type-argument (>= 'foo 1)) | |
| 684 (Check-Error wrong-type-argument (< 'foo 1)) | |
| 685 (Check-Error wrong-type-argument (> 'foo 1)) | |
| 686 (Check-Error wrong-type-argument (/= 'foo 1)) | |
| 687 | |
| 688 ;; Meat | |
| 689 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01)) | |
| 690 (dolist (two '(2 2.0 ?\02)) | |
| 2056 | 691 (Assert (< one two) (list one two)) |
| 692 (Assert (<= one two) (list one two)) | |
| 693 (Assert (<= two two) two) | |
| 694 (Assert (> two one) (list one two)) | |
| 695 (Assert (>= two one) (list one two)) | |
| 696 (Assert (>= two two) two) | |
| 697 (Assert (/= one two) (list one two)) | |
| 698 (Assert (not (/= two two)) two) | |
| 699 (Assert (not (< one one)) one) | |
| 700 (Assert (not (> one one)) one) | |
| 701 (Assert (<= one one two two) (list one two)) | |
| 702 (Assert (not (< one one two two)) (list one two)) | |
| 703 (Assert (>= two two one one) (list one two)) | |
| 704 (Assert (not (> two two one one)) (list one two)) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
705 (Assert (= one one one) one) |
| 2056 | 706 (Assert (not (= one one one two)) (list one two)) |
| 707 (Assert (not (/= one two one)) (list one two)) | |
| 428 | 708 )) |
| 709 | |
| 710 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01)) | |
| 711 (dolist (two '(2 2.0 ?\02)) | |
| 2056 | 712 (Assert (< one two) (list one two)) |
| 713 (Assert (<= one two) (list one two)) | |
| 714 (Assert (<= two two) two) | |
| 715 (Assert (> two one) (list one two)) | |
| 716 (Assert (>= two one) (list one two)) | |
| 717 (Assert (>= two two) two) | |
| 718 (Assert (/= one two) (list one two)) | |
| 719 (Assert (not (/= two two)) two) | |
| 720 (Assert (not (< one one)) one) | |
| 721 (Assert (not (> one one)) one) | |
| 722 (Assert (<= one one two two) (list one two)) | |
| 723 (Assert (not (< one one two two)) (list one two)) | |
| 724 (Assert (>= two two one one) (list one two)) | |
| 725 (Assert (not (> two two one one)) (list one two)) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
726 (Assert (= one one one) one) |
| 2056 | 727 (Assert (not (= one one one two)) (list one two)) |
| 728 (Assert (not (/= one two one)) (list one two)) | |
| 428 | 729 )) |
| 730 | |
| 731 ;; ad-hoc | |
| 732 (Assert (< 1 2)) | |
| 733 (Assert (< 1 2 3 4 5 6)) | |
| 734 (Assert (not (< 1 1))) | |
| 735 (Assert (not (< 2 1))) | |
| 736 | |
| 737 | |
| 738 (Assert (not (< 1 1))) | |
| 739 (Assert (< 1 2 3 4 5 6)) | |
| 740 (Assert (<= 1 2 3 4 5 6)) | |
| 741 (Assert (<= 1 2 3 4 5 6 6)) | |
| 742 (Assert (not (< 1 2 3 4 5 6 6))) | |
| 743 (Assert (<= 1 1)) | |
| 744 | |
| 745 (Assert (not (eq (point) (point-marker)))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
746 (Assert (= 1 (Int-to-Marker 1))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
747 (Assert (= (point) (point-marker))) |
| 428 | 748 |
| 1983 | 749 (when (featurep 'bignum) |
| 750 (let ((big1 (1+ most-positive-fixnum)) | |
| 751 (big2 (* 10 most-positive-fixnum)) | |
| 752 (small1 (1- most-negative-fixnum)) | |
| 753 (small2 (* 10 most-negative-fixnum))) | |
| 754 (Assert (< small2 small1 most-negative-fixnum most-positive-fixnum big1 | |
| 755 big2)) | |
| 756 (Assert (<= small2 small1 most-negative-fixnum most-positive-fixnum big1 | |
| 757 big2)) | |
| 758 (Assert (> big2 big1 most-positive-fixnum most-negative-fixnum small1 | |
| 759 small2)) | |
| 760 (Assert (>= big2 big1 most-positive-fixnum most-negative-fixnum small1 | |
| 761 small2)) | |
| 762 (Assert (/= small2 small1 most-negative-fixnum most-positive-fixnum big1 | |
| 763 big2)))) | |
| 764 | |
| 765 (when (featurep 'ratio) | |
| 766 (let ((big1 (div (* 10 most-positive-fixnum) 4)) | |
| 767 (big2 (div (* 5 most-positive-fixnum) 2)) | |
| 768 (big3 (div (* 7 most-positive-fixnum) 2)) | |
| 769 (small1 (div (* 10 most-negative-fixnum) 4)) | |
| 770 (small2 (div (* 5 most-negative-fixnum) 2)) | |
| 771 (small3 (div (* 7 most-negative-fixnum) 2))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
772 (Assert (= big1 big2)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
773 (Assert (= small1 small2)) |
| 1983 | 774 (Assert (< small3 small1 most-negative-fixnum most-positive-fixnum big1 |
| 775 big3)) | |
| 776 (Assert (<= small3 small2 small1 most-negative-fixnum most-positive-fixnum | |
| 777 big1 big2 big3)) | |
| 778 (Assert (> big3 big1 most-positive-fixnum most-negative-fixnum small1 | |
| 779 small3)) | |
| 780 (Assert (>= big3 big2 big1 most-positive-fixnum most-negative-fixnum | |
| 781 small1 small2 small3)) | |
| 782 (Assert (/= big3 big1 most-positive-fixnum most-negative-fixnum small1 | |
| 783 small3)))) | |
| 784 | |
| 428 | 785 ;;----------------------------------------------------- |
| 786 ;; testing list-walker functions | |
| 787 ;;----------------------------------------------------- | |
| 788 (macrolet | |
| 789 ((test-fun | |
| 790 (fun) | |
| 791 `(progn | |
| 792 (Check-Error wrong-number-of-arguments (,fun)) | |
| 793 (Check-Error wrong-number-of-arguments (,fun nil)) | |
|
5346
b4ef3128160c
Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5339
diff
changeset
|
794 (Check-Error (malformed-list wrong-type-argument) (,fun nil 1)) |
| 428 | 795 ,@(loop for n in '(1 2 2000) |
| 796 collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n)))))) | |
|
5374
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5370
diff
changeset
|
797 (test-funs (&rest funs) `(progn ,@(loop for fun in funs collect `(test-fun ,fun)))) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5370
diff
changeset
|
798 (test-old-funs (&rest funs) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5370
diff
changeset
|
799 `(when (and (fboundp 'old-eq) (subrp (symbol-function 'old-eq))) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5370
diff
changeset
|
800 ,@(loop for fun in funs collect `(test-fun ,fun))))) |
|
5346
b4ef3128160c
Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5339
diff
changeset
|
801 (test-funs member* member memq |
|
b4ef3128160c
Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5339
diff
changeset
|
802 assoc* assoc assq |
|
b4ef3128160c
Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5339
diff
changeset
|
803 rassoc* rassoc rassq |
|
b4ef3128160c
Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5339
diff
changeset
|
804 delete* delete delq |
|
b4ef3128160c
Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5339
diff
changeset
|
805 remove* remove remq |
|
5374
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5370
diff
changeset
|
806 remassoc remassq remrassoc remrassq) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5370
diff
changeset
|
807 (test-old-funs old-member old-memq old-assoc old-assq old-rassoc old-rassq |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5370
diff
changeset
|
808 old-delete old-delq)) |
| 428 | 809 |
| 810 (let ((x '((1 . 2) 3 (4 . 5)))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
811 (Assert (eq (assoc 1 x) (car x))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
812 (Assert (eq (assq 1 x) (car x))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
813 (Assert (eq (rassoc 1 x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
814 (Assert (eq (rassq 1 x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
815 (Assert (eq (assoc 2 x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
816 (Assert (eq (assq 2 x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
817 (Assert (eq (rassoc 2 x) (car x))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
818 (Assert (eq (rassq 2 x) (car x))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
819 (Assert (eq (assoc 3 x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
820 (Assert (eq (assq 3 x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
821 (Assert (eq (rassoc 3 x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
822 (Assert (eq (rassq 3 x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
823 (Assert (eq (assoc 4 x) (caddr x))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
824 (Assert (eq (assq 4 x) (caddr x))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
825 (Assert (eq (rassoc 4 x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
826 (Assert (eq (rassq 4 x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
827 (Assert (eq (assoc 5 x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
828 (Assert (eq (assq 5 x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
829 (Assert (eq (rassoc 5 x) (caddr x))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
830 (Assert (eq (rassq 5 x) (caddr x))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
831 (Assert (eq (assoc 6 x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
832 (Assert (eq (assq 6 x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
833 (Assert (eq (rassoc 6 x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
834 (Assert (eq (rassq 6 x) nil))) |
| 428 | 835 |
| 836 (let ((x '(("1" . "2") "3" ("4" . "5")))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
837 (Assert (eq (assoc "1" x) (car x))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
838 (Assert (eq (assq "1" x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
839 (Assert (eq (rassoc "1" x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
840 (Assert (eq (rassq "1" x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
841 (Assert (eq (assoc "2" x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
842 (Assert (eq (assq "2" x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
843 (Assert (eq (rassoc "2" x) (car x))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
844 (Assert (eq (rassq "2" x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
845 (Assert (eq (assoc "3" x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
846 (Assert (eq (assq "3" x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
847 (Assert (eq (rassoc "3" x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
848 (Assert (eq (rassq "3" x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
849 (Assert (eq (assoc "4" x) (caddr x))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
850 (Assert (eq (assq "4" x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
851 (Assert (eq (rassoc "4" x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
852 (Assert (eq (rassq "4" x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
853 (Assert (eq (assoc "5" x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
854 (Assert (eq (assq "5" x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
855 (Assert (eq (rassoc "5" x) (caddr x))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
856 (Assert (eq (rassq "5" x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
857 (Assert (eq (assoc "6" x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
858 (Assert (eq (assq "6" x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
859 (Assert (eq (rassoc "6" x) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
860 (Assert (eq (rassq "6" x) nil))) |
| 428 | 861 |
|
5576
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
862 (labels ((a () (list '(1 . 2) 3 '(4 . 5)))) |
| 428 | 863 (Assert (let* ((x (a)) (y (remassoc 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) |
| 864 (Assert (let* ((x (a)) (y (remassq 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
| 865 (Assert (let* ((x (a)) (y (remrassoc 1 x))) (and (eq x y) (equal y (a))))) | |
| 866 (Assert (let* ((x (a)) (y (remrassq 1 x))) (and (eq x y) (equal y (a))))) | |
| 867 | |
| 868 (Assert (let* ((x (a)) (y (remassoc 2 x))) (and (eq x y) (equal y (a))))) | |
| 869 (Assert (let* ((x (a)) (y (remassq 2 x))) (and (eq x y) (equal y (a))))) | |
| 870 (Assert (let* ((x (a)) (y (remrassoc 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
| 871 (Assert (let* ((x (a)) (y (remrassq 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
| 872 | |
| 873 (Assert (let* ((x (a)) (y (remassoc 3 x))) (and (eq x y) (equal y (a))))) | |
| 874 (Assert (let* ((x (a)) (y (remassq 3 x))) (and (eq x y) (equal y (a))))) | |
| 875 (Assert (let* ((x (a)) (y (remrassoc 3 x))) (and (eq x y) (equal y (a))))) | |
| 876 (Assert (let* ((x (a)) (y (remrassq 3 x))) (and (eq x y) (equal y (a))))) | |
| 877 | |
| 878 (Assert (let* ((x (a)) (y (remassoc 4 x))) (and (eq x y) (equal y '((1 . 2) 3))))) | |
| 879 (Assert (let* ((x (a)) (y (remassq 4 x))) (and (eq x y) (equal y '((1 . 2) 3))))) | |
| 880 (Assert (let* ((x (a)) (y (remrassoc 4 x))) (and (eq x y) (equal y (a))))) | |
| 881 (Assert (let* ((x (a)) (y (remrassq 4 x))) (and (eq x y) (equal y (a))))) | |
| 882 | |
| 883 (Assert (let* ((x (a)) (y (remassoc 5 x))) (and (eq x y) (equal y (a))))) | |
| 884 (Assert (let* ((x (a)) (y (remassq 5 x))) (and (eq x y) (equal y (a))))) | |
| 885 (Assert (let* ((x (a)) (y (remrassoc 5 x))) (and (eq x y) (equal y '((1 . 2) 3))))) | |
| 886 (Assert (let* ((x (a)) (y (remrassq 5 x))) (and (eq x y) (equal y '((1 . 2) 3))))) | |
| 887 | |
| 888 (Assert (let* ((x (a)) (y (remassoc 6 x))) (and (eq x y) (equal y (a))))) | |
| 889 (Assert (let* ((x (a)) (y (remassq 6 x))) (and (eq x y) (equal y (a))))) | |
| 890 (Assert (let* ((x (a)) (y (remrassoc 6 x))) (and (eq x y) (equal y (a))))) | |
| 891 (Assert (let* ((x (a)) (y (remrassq 6 x))) (and (eq x y) (equal y (a))))) | |
| 892 (Assert (let* ((x (a)) (y (delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) | |
| 893 (Assert (let* ((x (a)) (y (delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) | |
| 894 (Assert (let* ((x (a)) (y (delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
| 895 (Assert (let* ((x (a)) (y (delq '(1 . 2) x))) (and (eq x y) (equal y (a))))) | |
|
5374
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5370
diff
changeset
|
896 (when (and (fboundp 'old-eq) (subrp (symbol-function 'old-eq))) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5370
diff
changeset
|
897 (Assert (let* ((x (a)) (y (old-delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5370
diff
changeset
|
898 (Assert (let* ((x (a)) (y (old-delq '(1 . 2) x))) (and (eq x y) (equal y (a))))) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5370
diff
changeset
|
899 (Assert (let* ((x (a)) (y (old-delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5370
diff
changeset
|
900 (Assert (let* ((x (a)) (y (old-delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))))) |
| 428 | 901 |
|
5576
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
902 (labels ((a () (list '("1" . "2") "3" '("4" . "5")))) |
| 428 | 903 (Assert (let* ((x (a)) (y (remassoc "1" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5")))))) |
| 904 (Assert (let* ((x (a)) (y (remassq "1" x))) (and (eq x y) (equal y (a))))) | |
| 905 (Assert (let* ((x (a)) (y (remrassoc "1" x))) (and (eq x y) (equal y (a))))) | |
| 906 (Assert (let* ((x (a)) (y (remrassq "1" x))) (and (eq x y) (equal y (a))))) | |
| 907 | |
| 908 (Assert (let* ((x (a)) (y (remassoc "2" x))) (and (eq x y) (equal y (a))))) | |
| 909 (Assert (let* ((x (a)) (y (remassq "2" x))) (and (eq x y) (equal y (a))))) | |
| 910 (Assert (let* ((x (a)) (y (remrassoc "2" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5")))))) | |
| 911 (Assert (let* ((x (a)) (y (remrassq "2" x))) (and (eq x y) (equal y (a))))) | |
| 912 | |
| 913 (Assert (let* ((x (a)) (y (remassoc "3" x))) (and (eq x y) (equal y (a))))) | |
| 914 (Assert (let* ((x (a)) (y (remassq "3" x))) (and (eq x y) (equal y (a))))) | |
| 915 (Assert (let* ((x (a)) (y (remrassoc "3" x))) (and (eq x y) (equal y (a))))) | |
| 916 (Assert (let* ((x (a)) (y (remrassq "3" x))) (and (eq x y) (equal y (a))))) | |
| 917 | |
| 918 (Assert (let* ((x (a)) (y (remassoc "4" x))) (and (eq x y) (equal y '(("1" . "2") "3"))))) | |
| 919 (Assert (let* ((x (a)) (y (remassq "4" x))) (and (eq x y) (equal y (a))))) | |
| 920 (Assert (let* ((x (a)) (y (remrassoc "4" x))) (and (eq x y) (equal y (a))))) | |
| 921 (Assert (let* ((x (a)) (y (remrassq "4" x))) (and (eq x y) (equal y (a))))) | |
| 922 | |
| 923 (Assert (let* ((x (a)) (y (remassoc "5" x))) (and (eq x y) (equal y (a))))) | |
| 924 (Assert (let* ((x (a)) (y (remassq "5" x))) (and (eq x y) (equal y (a))))) | |
| 925 (Assert (let* ((x (a)) (y (remrassoc "5" x))) (and (eq x y) (equal y '(("1" . "2") "3"))))) | |
| 926 (Assert (let* ((x (a)) (y (remrassq "5" x))) (and (eq x y) (equal y (a))))) | |
| 927 | |
| 928 (Assert (let* ((x (a)) (y (remassoc "6" x))) (and (eq x y) (equal y (a))))) | |
| 929 (Assert (let* ((x (a)) (y (remassq "6" x))) (and (eq x y) (equal y (a))))) | |
| 930 (Assert (let* ((x (a)) (y (remrassoc "6" x))) (and (eq x y) (equal y (a))))) | |
| 931 (Assert (let* ((x (a)) (y (remrassq "6" x))) (and (eq x y) (equal y (a)))))) | |
| 932 | |
| 933 ;;----------------------------------------------------- | |
| 934 ;; function-max-args, function-min-args | |
| 935 ;;----------------------------------------------------- | |
| 936 (defmacro check-function-argcounts (fun min max) | |
| 937 `(progn | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
938 (Assert (eq (function-min-args ,fun) ,min)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
939 (Assert (eq (function-max-args ,fun) ,max)))) |
| 428 | 940 |
| 941 (check-function-argcounts 'prog1 1 nil) ; special form | |
| 942 (check-function-argcounts 'command-execute 1 3) ; normal subr | |
| 943 (check-function-argcounts 'funcall 1 nil) ; `MANY' subr | |
| 944 (check-function-argcounts 'garbage-collect 0 0) ; no args subr | |
| 945 | |
| 946 ;; Test interpreted and compiled functions | |
| 947 (loop for (arglist min max) in | |
| 948 '(((arg1 arg2 &rest args) 2 nil) | |
| 949 ((arg1 arg2 &optional arg3 arg4) 2 4) | |
| 950 ((arg1 arg2 &optional arg3 arg4 &rest args) 2 nil) | |
| 951 (() 0 0)) | |
| 952 do | |
| 953 (eval | |
| 954 `(progn | |
| 955 (defun test-fun ,arglist nil) | |
| 956 (check-function-argcounts '(lambda ,arglist nil) ,min ,max) | |
| 957 (check-function-argcounts (byte-compile '(lambda ,arglist nil)) ,min ,max)))) | |
| 958 | |
|
4575
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
959 ;; Test subr-arity. |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
960 (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
|
961 '((let (1 . unevalled)) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
962 (prog1 (1 . unevalled)) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
963 (list (0 . many)) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
964 (type-of (1 . 1)) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
965 (garbage-collect (0 . 0))) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
966 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
|
967 |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
968 (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
|
969 (lambda () (message "Hi there!")))) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
970 |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
971 (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
|
972 |
| 428 | 973 ;;----------------------------------------------------- |
| 974 ;; Detection of cyclic variable indirection loops | |
| 975 ;;----------------------------------------------------- | |
| 976 (fset 'test-sym1 'test-sym1) | |
| 977 (Check-Error cyclic-function-indirection (test-sym1)) | |
| 978 | |
| 979 (fset 'test-sym1 'test-sym2) | |
| 980 (fset 'test-sym2 'test-sym1) | |
| 981 (Check-Error cyclic-function-indirection (test-sym1)) | |
| 982 (fmakunbound 'test-sym1) ; else macroexpand-internal infloops! | |
| 983 (fmakunbound 'test-sym2) | |
| 984 | |
| 985 ;;----------------------------------------------------- | |
| 986 ;; Test `type-of' | |
| 987 ;;----------------------------------------------------- | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
988 (Assert (eq (type-of load-path) 'cons)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
989 (Assert (eq (type-of obarray) 'vector)) |
|
5595
391d809fa4e9
Update tests that have started failing because of changed design decisions.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5576
diff
changeset
|
990 (Assert (eq (type-of 42) 'fixnum)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
991 (Assert (eq (type-of ?z) 'character)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
992 (Assert (eq (type-of "42") 'string)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
993 (Assert (eq (type-of 'foo) 'symbol)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
994 (Assert (eq (type-of (selected-device)) 'device)) |
| 428 | 995 |
| 996 ;;----------------------------------------------------- | |
| 997 ;; Test mapping functions | |
| 998 ;;----------------------------------------------------- | |
| 999 (Check-Error wrong-type-argument (mapcar #'identity (current-buffer))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1000 (Assert (equal (mapcar #'identity load-path) load-path)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1001 (Assert (equal (mapcar #'identity '(1 2 3)) '(1 2 3))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1002 (Assert (equal (mapcar #'identity "123") '(?1 ?2 ?3))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1003 (Assert (equal (mapcar #'identity [1 2 3]) '(1 2 3))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1004 (Assert (equal (mapcar #'identity #*010) '(0 1 0))) |
| 428 | 1005 |
| 1006 (let ((z 0) (list (make-list 1000 1))) | |
| 1007 (mapc (lambda (x) (incf z x)) list) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1008 (Assert (eq 1000 z))) |
| 428 | 1009 |
| 1010 (Check-Error wrong-type-argument (mapvector #'identity (current-buffer))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1011 (Assert (equal (mapvector #'identity '(1 2 3)) [1 2 3])) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1012 (Assert (equal (mapvector #'identity "123") [?1 ?2 ?3])) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1013 (Assert (equal (mapvector #'identity [1 2 3]) [1 2 3])) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1014 (Assert (equal (mapvector #'identity #*010) [0 1 0])) |
| 428 | 1015 |
| 1016 (Check-Error wrong-type-argument (mapconcat #'identity (current-buffer) "foo")) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1017 (Assert (equal (mapconcat #'identity '("1" "2" "3") "|") "1|2|3")) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1018 (Assert (equal (mapconcat #'identity ["1" "2" "3"] "|") "1|2|3")) |
| 428 | 1019 |
| 434 | 1020 ;; The following 2 functions used to crash XEmacs via mapcar1(). |
| 1021 ;; We don't test the actual values of the mapcar, since they're undefined. | |
| 446 | 1022 (Assert |
| 434 | 1023 (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3)))) |
| 1024 (mapcar | |
| 1025 (lambda (y) | |
| 1026 "Devious evil mapping function" | |
| 1027 (when (eq (car y) 2) ; go out onto a limb | |
| 1028 (setcdr x nil) ; cut it off behind us | |
| 1029 (garbage-collect)) ; are we riding a magic broomstick? | |
| 1030 (car y)) ; sorry, hard landing | |
| 1031 x))) | |
| 1032 | |
| 446 | 1033 (Assert |
| 434 | 1034 (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3)))) |
| 1035 (mapcar | |
| 1036 (lambda (y) | |
| 1037 "Devious evil mapping function" | |
| 1038 (when (eq (car y) 1) | |
| 1039 (setcdr (cdr x) 42)) ; drop a brick wall onto the freeway | |
| 1040 (car y)) | |
| 1041 x))) | |
| 1042 | |
|
5355
70b15ac66ee5
Correct a bug with circularity checking in #'mapcar*, #'map, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5353
diff
changeset
|
1043 (Assert |
|
70b15ac66ee5
Correct a bug with circularity checking in #'mapcar*, #'map, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5353
diff
changeset
|
1044 (equal |
|
70b15ac66ee5
Correct a bug with circularity checking in #'mapcar*, #'map, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5353
diff
changeset
|
1045 (let ((list (list pi))) (mapcar* #'cons [1 2 3 4] (nconc list list))) |
|
70b15ac66ee5
Correct a bug with circularity checking in #'mapcar*, #'map, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5353
diff
changeset
|
1046 `((1 . ,pi) (2 . ,pi) (3 . ,pi) (4 . ,pi))) |
|
70b15ac66ee5
Correct a bug with circularity checking in #'mapcar*, #'map, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5353
diff
changeset
|
1047 "checking mapcar* behaves correctly when only one arg is circular") |
|
70b15ac66ee5
Correct a bug with circularity checking in #'mapcar*, #'map, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5353
diff
changeset
|
1048 |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1049 (Assert (eql |
|
5034
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4906
diff
changeset
|
1050 (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
|
1051 (car (mapcar #'(lambda (argument) (floor argument)) (list pi e))))) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1052 1) |
|
5034
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4906
diff
changeset
|
1053 "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
|
1054 |
|
5299
28651c24b3f8
Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents:
5295
diff
changeset
|
1055 (let ((malformed-list '(1 2 3 4 hi there . tail))) |
|
28651c24b3f8
Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents:
5295
diff
changeset
|
1056 (Check-Error malformed-list (mapcar #'identity malformed-list)) |
|
28651c24b3f8
Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents:
5295
diff
changeset
|
1057 (Check-Error malformed-list (map nil #'eq [1 2 3 4] |
|
28651c24b3f8
Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents:
5295
diff
changeset
|
1058 malformed-list)) |
|
28651c24b3f8
Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents:
5295
diff
changeset
|
1059 (Check-Error malformed-list (list-length malformed-list))) |
|
28651c24b3f8
Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents:
5295
diff
changeset
|
1060 |
| 428 | 1061 ;;----------------------------------------------------- |
| 1062 ;; Test vector functions | |
| 1063 ;;----------------------------------------------------- | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1064 (Assert (equal [1 2 3] [1 2 3])) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1065 (Assert (equal [] [])) |
| 428 | 1066 (Assert (not (equal [1 2 3] []))) |
| 1067 (Assert (not (equal [1 2 3] [1 2 4]))) | |
| 1068 (Assert (not (equal [0 2 3] [1 2 3]))) | |
| 1069 (Assert (not (equal [1 2 3] [1 2 3 4]))) | |
| 1070 (Assert (not (equal [1 2 3 4] [1 2 3]))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1071 (Assert (equal (vector 1 2 3) [1 2 3])) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1072 (Assert (equal (make-vector 3 1) [1 1 1])) |
| 428 | 1073 |
| 1074 ;;----------------------------------------------------- | |
| 1075 ;; Test bit-vector functions | |
| 1076 ;;----------------------------------------------------- | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1077 (Assert (equal #*010 #*010)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1078 (Assert (equal #* #*)) |
| 428 | 1079 (Assert (not (equal #*010 #*011))) |
| 1080 (Assert (not (equal #*010 #*))) | |
| 1081 (Assert (not (equal #*110 #*010))) | |
| 1082 (Assert (not (equal #*010 #*0100))) | |
| 1083 (Assert (not (equal #*0101 #*010))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1084 (Assert (equal (bit-vector 0 1 0) #*010)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1085 (Assert (equal (make-bit-vector 3 1) #*111)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1086 (Assert (equal (make-bit-vector 3 0) #*000)) |
| 428 | 1087 |
| 1088 ;;----------------------------------------------------- | |
| 1089 ;; Test buffer-local variables used as (ugh!) function parameters | |
| 1090 ;;----------------------------------------------------- | |
| 1091 (make-local-variable 'test-emacs-buffer-local-variable) | |
| 1092 (byte-compile | |
| 1093 (defun test-emacs-buffer-local-parameter (test-emacs-buffer-local-variable) | |
| 1094 (setq test-emacs-buffer-local-variable nil))) | |
| 1095 (test-emacs-buffer-local-parameter nil) | |
| 1096 | |
| 1097 ;;----------------------------------------------------- | |
| 1098 ;; Test split-string | |
| 1099 ;;----------------------------------------------------- | |
| 1425 | 1100 ;; Keep nulls, explicit SEPARATORS |
| 1101 ;; Hrvoje didn't like the next 3 tests so I'm disabling them for now. -sb | |
| 1102 ;; I assume Hrvoje worried about the possibility of infloops. -sjt | |
| 1103 (when test-harness-risk-infloops | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1104 (Assert (equal (split-string "foo" "") '("" "f" "o" "o" ""))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1105 (Assert (equal (split-string "foo" "^") '("" "foo"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1106 (Assert (equal (split-string "foo" "$") '("foo" "")))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1107 (Assert (equal (split-string "foo,bar" ",") '("foo" "bar"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1108 (Assert (equal (split-string ",foo,bar," ",") '("" "foo" "bar" ""))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1109 (Assert (equal (split-string ",foo,bar," "^,") '("" "foo,bar,"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1110 (Assert (equal (split-string ",foo,bar," ",$") '(",foo,bar" ""))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1111 (Assert (equal (split-string ",foo,,bar," ",") '("" "foo" "" "bar" ""))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1112 (Assert (equal (split-string "foo,,,bar" ",") '("foo" "" "" "bar"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1113 (Assert (equal (split-string "foo,,bar,," ",") '("foo" "" "bar" "" ""))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1114 (Assert (equal (split-string "foo,,bar" ",+") '("foo" "bar"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1115 (Assert (equal (split-string ",foo,,bar," ",+") '("" "foo" "bar" ""))) |
| 1425 | 1116 ;; Omit nulls, explicit SEPARATORS |
| 1117 (when test-harness-risk-infloops | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1118 (Assert (equal (split-string "foo" "" t) '("f" "o" "o"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1119 (Assert (equal (split-string "foo" "^" t) '("foo"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1120 (Assert (equal (split-string "foo" "$" t) '("foo")))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1121 (Assert (equal (split-string "foo,bar" "," t) '("foo" "bar"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1122 (Assert (equal (split-string ",foo,bar," "," t) '("foo" "bar"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1123 (Assert (equal (split-string ",foo,bar," "^," t) '("foo,bar,"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1124 (Assert (equal (split-string ",foo,bar," ",$" t) '(",foo,bar"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1125 (Assert (equal (split-string ",foo,,bar," "," t) '("foo" "bar"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1126 (Assert (equal (split-string "foo,,,bar" "," t) '("foo" "bar"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1127 (Assert (equal (split-string "foo,,bar,," "," t) '("foo" "bar"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1128 (Assert (equal (split-string "foo,,bar" ",+" t) '("foo" "bar"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1129 (Assert (equal (split-string ",foo,,bar," ",+" t) '("foo" "bar"))) |
| 1425 | 1130 ;; "Double-default" case |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1131 (Assert (equal (split-string "foo bar") '("foo" "bar"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1132 (Assert (equal (split-string " foo bar ") '("foo" "bar"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1133 (Assert (equal (split-string " foo bar ") '("foo" "bar"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1134 (Assert (equal (split-string "foo bar") '("foo" "bar"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1135 (Assert (equal (split-string "foo bar ") '("foo" "bar"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1136 (Assert (equal (split-string "foobar") '("foobar"))) |
| 1425 | 1137 ;; Semantics are identical to "double-default" case! Fool ya? |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1138 (Assert (equal (split-string "foo bar" nil t) '("foo" "bar"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1139 (Assert (equal (split-string " foo bar " nil t) '("foo" "bar"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1140 (Assert (equal (split-string " foo bar " nil t) '("foo" "bar"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1141 (Assert (equal (split-string "foo bar" nil t) '("foo" "bar"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1142 (Assert (equal (split-string "foo bar " nil t) '("foo" "bar"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1143 (Assert (equal (split-string "foobar" nil t) '("foobar"))) |
| 1425 | 1144 ;; Perverse "anti-double-default" case |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1145 (Assert (equal (split-string "foo bar" split-string-default-separators) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1146 '("foo" "bar"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1147 (Assert (equal (split-string " foo bar " split-string-default-separators) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1148 '("" "foo" "bar" ""))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1149 (Assert (equal (split-string " foo bar " split-string-default-separators) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1150 '("" "foo" "bar" ""))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1151 (Assert (equal (split-string "foo bar" split-string-default-separators) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1152 '("foo" "bar"))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1153 (Assert (equal (split-string "foo bar " split-string-default-separators) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1154 '("foo" "bar" ""))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1155 (Assert (equal (split-string "foobar" split-string-default-separators) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1156 '("foobar"))) |
| 434 | 1157 |
| 1158 ;;----------------------------------------------------- | |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1159 ;; 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
|
1160 ;;----------------------------------------------------- |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1161 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1162 (Assert |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1163 (equal |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1164 (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
|
1165 #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
|
1166 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
|
1167 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
|
1168 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
|
1169 unreinen\: Geister brüten.\\ |
|
5036
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1170 Serum concentrations of vitamin E: (alpha-tocopherol) depend on the liver, |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1171 which takes up the nutrient after the various forms are absorbed from the |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1172 small intestine. The liver preferentially resecretes only alpha-tocopherol |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1173 via the hepatic alpha-tocopherol transfer protein" |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1174 ?: ?\\) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1175 '("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
|
1176 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
|
1177 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
|
1178 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
|
1179 unreinen: Geister brüten.\\ |
|
5036
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1180 Serum concentrations of vitamin E" " (alpha-tocopherol) depend on the liver, |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1181 which takes up the nutrient after the various forms are absorbed from the |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1182 small intestine. The liver preferentially resecretes only alpha-tocopherol |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1183 via the hepatic alpha-tocopherol transfer protein"))) |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1184 (Assert |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1185 (equal |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1186 (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
|
1187 #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
|
1188 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
|
1189 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
|
1190 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
|
1191 unreinen\: Geister brüten.\\ |
|
5036
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1192 Serum concentrations of vitamin E: (alpha-tocopherol) depend on the liver, |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1193 which takes up the nutrient after the various forms are absorbed from the |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1194 small intestine. The liver preferentially resecretes only alpha-tocopherol |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1195 via the hepatic alpha-tocopherol transfer protein" |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1196 ?: ?\x00) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1197 '("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
|
1198 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
|
1199 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
|
1200 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
|
1201 unreinen\\" " Geister brüten.\\\\ |
|
5036
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1202 Serum concentrations of vitamin E" " (alpha-tocopherol) depend on the liver, |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1203 which takes up the nutrient after the various forms are absorbed from the |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1204 small intestine. The liver preferentially resecretes only alpha-tocopherol |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1205 via the hepatic alpha-tocopherol transfer protein"))) |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1206 (Assert |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1207 (equal |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1208 (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
|
1209 #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
|
1210 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
|
1211 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
|
1212 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
|
1213 unreinen\: Geister brüten.\\ |
|
5036
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1214 Serum concentrations of vitamin E: (alpha-tocopherol) depend on the liver, |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1215 which takes up the nutrient after the various forms are absorbed from the |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1216 small intestine. The liver preferentially resecretes only alpha-tocopherol |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1217 via the hepatic alpha-tocopherol transfer protein" ?\\) |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1218 '("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
|
1219 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
|
1220 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
|
1221 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
|
1222 unreinen" ": Geister brüten." "" " |
|
5036
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1223 Serum concentrations of vitamin E: (alpha-tocopherol) depend on the liver, |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1224 which takes up the nutrient after the various forms are absorbed from the |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1225 small intestine. The liver preferentially resecretes only alpha-tocopherol |
|
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1226 via the hepatic alpha-tocopherol transfer protein"))) |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1227 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1228 ;;----------------------------------------------------- |
| 434 | 1229 ;; Test near-text buffer functions. |
| 1230 ;;----------------------------------------------------- | |
| 1231 (with-temp-buffer | |
| 1232 (erase-buffer) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1233 (Assert (eq (char-before) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1234 (Assert (eq (char-before (point)) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1235 (Assert (eq (char-before (point-marker)) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1236 (Assert (eq (char-before (point) (current-buffer)) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1237 (Assert (eq (char-before (point-marker) (current-buffer)) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1238 (Assert (eq (char-after) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1239 (Assert (eq (char-after (point)) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1240 (Assert (eq (char-after (point-marker)) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1241 (Assert (eq (char-after (point) (current-buffer)) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1242 (Assert (eq (char-after (point-marker) (current-buffer)) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1243 (Assert (eq (preceding-char) 0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1244 (Assert (eq (preceding-char (current-buffer)) 0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1245 (Assert (eq (following-char) 0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1246 (Assert (eq (following-char (current-buffer)) 0)) |
| 434 | 1247 (insert "foobar") |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1248 (Assert (eq (char-before) ?r)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1249 (Assert (eq (char-after) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1250 (Assert (eq (preceding-char) ?r)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1251 (Assert (eq (following-char) 0)) |
| 434 | 1252 (goto-char (point-min)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1253 (Assert (eq (char-before) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1254 (Assert (eq (char-after) ?f)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1255 (Assert (eq (preceding-char) 0)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1256 (Assert (eq (following-char) ?f)) |
| 434 | 1257 ) |
| 440 | 1258 |
| 1259 ;;----------------------------------------------------- | |
| 1260 ;; Test plist manipulation functions. | |
| 1261 ;;----------------------------------------------------- | |
| 1262 (let ((sym (make-symbol "test-symbol"))) | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1263 (Assert (eq t (get* sym t t))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1264 (Assert (eq t (get sym t t))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1265 (Assert (eq t (getf nil t t))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1266 (Assert (eq t (plist-get nil t t))) |
| 440 | 1267 (put sym 'bar 'baz) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1268 (Assert (eq 'baz (get sym 'bar))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1269 (Assert (eq 'baz (getf '(bar baz) 'bar))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1270 (Assert (eq 'baz (getf (symbol-plist sym) 'bar))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1271 (Assert (eq 2 (getf '(1 2) 1))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1272 (Assert (eq 4 (put sym 3 4))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1273 (Assert (eq 4 (get sym 3))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1274 (Assert (eq t (remprop sym 3))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1275 (Assert (eq nil (remprop sym 3))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1276 (Assert (eq 5 (get sym 3 5))) |
| 440 | 1277 ) |
| 442 | 1278 |
| 1279 (loop for obj in | |
| 1280 (list (make-symbol "test-symbol") | |
| 1281 "test-string" | |
| 1282 (make-extent nil nil nil) | |
| 1283 (make-face 'test-face)) | |
| 1284 do | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1285 (Assert (eq 2 (get obj ?1 2)) obj) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1286 (Assert (eq 4 (put obj ?3 4)) obj) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1287 (Assert (eq 4 (get obj ?3)) obj) |
| 442 | 1288 (when (or (stringp obj) (symbolp obj)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1289 (Assert (equal '(?3 4) (object-plist obj)) obj)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1290 (Assert (eq t (remprop obj ?3)) obj) |
| 442 | 1291 (when (or (stringp obj) (symbolp obj)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1292 (Assert (eq '() (object-plist obj)) obj)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1293 (Assert (eq nil (remprop obj ?3)) obj) |
| 442 | 1294 (when (or (stringp obj) (symbolp obj)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1295 (Assert (eq '() (object-plist obj)) obj)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1296 (Assert (eq 5 (get obj ?3 5)) obj) |
| 442 | 1297 ) |
| 1298 | |
| 1299 (Check-Error-Message | |
| 1300 error "Object type has no properties" | |
| 1301 (get 2 'property)) | |
| 1302 | |
| 1303 (Check-Error-Message | |
| 1304 error "Object type has no settable properties" | |
| 1305 (put (current-buffer) 'property 'value)) | |
| 1306 | |
| 1307 (Check-Error-Message | |
| 1308 error "Object type has no removable properties" | |
| 1309 (remprop ?3 'property)) | |
| 1310 | |
| 1311 (Check-Error-Message | |
| 1312 error "Object type has no properties" | |
| 1313 (object-plist (symbol-function 'car))) | |
| 1314 | |
| 1315 (Check-Error-Message | |
| 1316 error "Can't remove property from object" | |
| 1317 (remprop (make-extent nil nil nil) 'detachable)) | |
| 1318 | |
| 1319 ;;----------------------------------------------------- | |
| 1320 ;; Test subseq | |
| 1321 ;;----------------------------------------------------- | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1322 (Assert (equal (subseq nil 0) nil)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1323 (Assert (equal (subseq [1 2 3] 0) [1 2 3])) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1324 (Assert (equal (subseq [1 2 3] 1 -1) [2])) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1325 (Assert (equal (subseq "123" 0) "123")) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1326 (Assert (equal (subseq "1234" -3 -1) "23")) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1327 (Assert (equal (subseq #*0011 0) #*0011)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1328 (Assert (equal (subseq #*0011 -3 3) #*01)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1329 (Assert (equal (subseq '(1 2 3) 0) '(1 2 3))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1330 (Assert (equal (subseq '(1 2 3 4) -3 nil) '(2 3 4))) |
| 442 | 1331 |
| 446 | 1332 (Check-Error wrong-type-argument (subseq 3 2)) |
| 1333 (Check-Error args-out-of-range (subseq [1 2 3] -42)) | |
| 1334 (Check-Error args-out-of-range (subseq [1 2 3] 0 42)) | |
| 442 | 1335 |
|
5370
4c4b96b13f70
Address the easy test failures in tests/automated.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
1336 (let ((string "hi there")) |
|
4c4b96b13f70
Address the easy test failures in tests/automated.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
1337 (Assert (equal (substring-no-properties "123" 0) "123")) |
|
4c4b96b13f70
Address the easy test failures in tests/automated.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
1338 (Assert (equal (substring-no-properties "1234" -3 -1) "23")) |
|
4c4b96b13f70
Address the easy test failures in tests/automated.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
1339 (Assert (equal (substring-no-properties "hi there" 0) "hi there")) |
|
4c4b96b13f70
Address the easy test failures in tests/automated.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
1340 (put-text-property 0 (length string) 'foo 'bar string) |
|
4c4b96b13f70
Address the easy test failures in tests/automated.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
1341 (Assert (eq 'bar (get-text-property 0 'foo string))) |
|
4c4b96b13f70
Address the easy test failures in tests/automated.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
1342 (Assert (not |
|
4c4b96b13f70
Address the easy test failures in tests/automated.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
1343 (get-text-property 0 'foo (substring-no-properties "hi there" 0)))) |
|
4c4b96b13f70
Address the easy test failures in tests/automated.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
1344 (Check-Error wrong-type-argument (substring-no-properties nil 4)) |
|
4c4b96b13f70
Address the easy test failures in tests/automated.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
1345 (Check-Error wrong-type-argument (substring-no-properties "hi there" pi)) |
|
4c4b96b13f70
Address the easy test failures in tests/automated.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
1346 (Check-Error wrong-type-argument (substring-no-properties "hi there" 0.0))) |
|
5360
46b53e84ea7a
#'substring-no-properties: check STRING's type, get_string_range_char won't.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5355
diff
changeset
|
1347 |
| 442 | 1348 ;;----------------------------------------------------- |
| 1349 ;; Time-related tests | |
| 1350 ;;----------------------------------------------------- | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1351 (Assert (= (length (current-time-string)) 24)) |
| 444 | 1352 |
| 1353 ;;----------------------------------------------------- | |
| 1354 ;; format test | |
| 1355 ;;----------------------------------------------------- | |
| 1356 (Assert (string= (format "%d" 10) "10")) | |
| 1357 (Assert (string= (format "%o" 8) "10")) | |
|
5295
2474dce7304e
Make sure (format "%b" 0) is non-zero length, print.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
1358 (Assert (string= (format "%b" 2) "10")) |
| 444 | 1359 (Assert (string= (format "%x" 31) "1f")) |
| 1360 (Assert (string= (format "%X" 31) "1F")) | |
|
5295
2474dce7304e
Make sure (format "%b" 0) is non-zero length, print.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
1361 (Assert (string= (format "%b" 0) "0")) |
|
2474dce7304e
Make sure (format "%b" 0) is non-zero length, print.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
1362 (Assert (string= (format "%b" 3) "11")) |
| 826 | 1363 ;; MS-Windows uses +002 in its floating-point numbers. #### We should |
| 1364 ;; perhaps fix this, but writing our own floating-point support in doprnt.c | |
| 1365 ;; is very hard. | |
| 1366 (Assert (or (string= (format "%e" 100) "1.000000e+02") | |
| 1367 (string= (format "%e" 100) "1.000000e+002"))) | |
| 1368 (Assert (or (string= (format "%E" 100) "1.000000E+02") | |
| 1369 (string= (format "%E" 100) "1.000000E+002"))) | |
| 1370 (Assert (or (string= (format "%E" 100) "1.000000E+02") | |
| 1371 (string= (format "%E" 100) "1.000000E+002"))) | |
| 444 | 1372 (Assert (string= (format "%f" 100) "100.000000")) |
| 448 | 1373 (Assert (string= (format "%7.3f" 12.12345) " 12.123")) |
| 1374 (Assert (string= (format "%07.3f" 12.12345) "012.123")) | |
| 1375 (Assert (string= (format "%-7.3f" 12.12345) "12.123 ")) | |
| 1376 (Assert (string= (format "%-07.3f" 12.12345) "12.123 ")) | |
| 444 | 1377 (Assert (string= (format "%g" 100.0) "100")) |
| 826 | 1378 (Assert (or (string= (format "%g" 0.000001) "1e-06") |
| 1379 (string= (format "%g" 0.000001) "1e-006"))) | |
| 444 | 1380 (Assert (string= (format "%g" 0.0001) "0.0001")) |
| 1381 (Assert (string= (format "%G" 100.0) "100")) | |
| 826 | 1382 (Assert (or (string= (format "%G" 0.000001) "1E-06") |
| 1383 (string= (format "%G" 0.000001) "1E-006"))) | |
| 444 | 1384 (Assert (string= (format "%G" 0.0001) "0.0001")) |
| 1385 | |
| 1386 (Assert (string= (format "%2$d%1$d" 10 20) "2010")) | |
| 1387 (Assert (string= (format "%-d" 10) "10")) | |
| 1388 (Assert (string= (format "%-4d" 10) "10 ")) | |
| 1389 (Assert (string= (format "%+d" 10) "+10")) | |
| 1390 (Assert (string= (format "%+d" -10) "-10")) | |
| 1391 (Assert (string= (format "%+4d" 10) " +10")) | |
| 1392 (Assert (string= (format "%+4d" -10) " -10")) | |
| 1393 (Assert (string= (format "% d" 10) " 10")) | |
| 1394 (Assert (string= (format "% d" -10) "-10")) | |
| 1395 (Assert (string= (format "% 4d" 10) " 10")) | |
| 1396 (Assert (string= (format "% 4d" -10) " -10")) | |
| 1397 (Assert (string= (format "%0d" 10) "10")) | |
| 1398 (Assert (string= (format "%0d" -10) "-10")) | |
| 1399 (Assert (string= (format "%04d" 10) "0010")) | |
| 1400 (Assert (string= (format "%04d" -10) "-010")) | |
| 1401 (Assert (string= (format "%*d" 4 10) " 10")) | |
| 1402 (Assert (string= (format "%*d" 4 -10) " -10")) | |
| 1403 (Assert (string= (format "%*d" -4 10) "10 ")) | |
| 1404 (Assert (string= (format "%*d" -4 -10) "-10 ")) | |
| 1405 (Assert (string= (format "%#d" 10) "10")) | |
| 1406 (Assert (string= (format "%#o" 8) "010")) | |
| 1407 (Assert (string= (format "%#x" 16) "0x10")) | |
| 826 | 1408 (Assert (or (string= (format "%#e" 100) "1.000000e+02") |
| 1409 (string= (format "%#e" 100) "1.000000e+002"))) | |
| 1410 (Assert (or (string= (format "%#E" 100) "1.000000E+02") | |
| 1411 (string= (format "%#E" 100) "1.000000E+002"))) | |
| 444 | 1412 (Assert (string= (format "%#f" 100) "100.000000")) |
| 1413 (Assert (string= (format "%#g" 100.0) "100.000")) | |
| 826 | 1414 (Assert (or (string= (format "%#g" 0.000001) "1.00000e-06") |
| 1415 (string= (format "%#g" 0.000001) "1.00000e-006"))) | |
| 444 | 1416 (Assert (string= (format "%#g" 0.0001) "0.000100000")) |
| 1417 (Assert (string= (format "%#G" 100.0) "100.000")) | |
| 826 | 1418 (Assert (or (string= (format "%#G" 0.000001) "1.00000E-06") |
| 1419 (string= (format "%#G" 0.000001) "1.00000E-006"))) | |
| 444 | 1420 (Assert (string= (format "%#G" 0.0001) "0.000100000")) |
| 1421 (Assert (string= (format "%.1d" 10) "10")) | |
| 1422 (Assert (string= (format "%.4d" 10) "0010")) | |
| 1423 ;; Combination of `-', `+', ` ', `0', `#', `.', `*' | |
| 448 | 1424 (Assert (string= (format "%-04d" 10) "10 ")) |
| 444 | 1425 (Assert (string= (format "%-*d" 4 10) "10 ")) |
| 1426 ;; #### Correctness of this behavior is questionable. | |
| 1427 ;; It might be better to signal error. | |
| 1428 (Assert (string= (format "%-*d" -4 10) "10 ")) | |
| 1429 ;; These behavior is not specified. | |
| 1430 ;; (format "%-+d" 10) | |
| 1431 ;; (format "%- d" 10) | |
| 1432 ;; (format "%-01d" 10) | |
| 1433 ;; (format "%-#4x" 10) | |
| 1434 ;; (format "%-.1d" 10) | |
| 1435 | |
| 1436 (Assert (string= (format "%01.1d" 10) "10")) | |
| 448 | 1437 (Assert (string= (format "%03.1d" 10) " 10")) |
| 1438 (Assert (string= (format "%01.3d" 10) "010")) | |
| 1439 (Assert (string= (format "%1.3d" 10) "010")) | |
| 444 | 1440 (Assert (string= (format "%3.1d" 10) " 10")) |
| 446 | 1441 |
| 448 | 1442 ;;; The following two tests used to use 1000 instead of 100, |
| 1443 ;;; but that merely found buffer overflow bugs in Solaris sprintf(). | |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1444 (Assert (= 102 (length (format "%.100f" 3.14)))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1445 (Assert (= 100 (length (format "%100f" 3.14)))) |
| 448 | 1446 |
| 446 | 1447 ;;; Check for 64-bit cleanness on LP64 platforms. |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1448 (Assert (= (read (format "%d" most-positive-fixnum)) most-positive-fixnum)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1449 (Assert (= (read (format "%ld" most-positive-fixnum)) most-positive-fixnum)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1450 (Assert (= (read (format "%u" most-positive-fixnum)) most-positive-fixnum)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1451 (Assert (= (read (format "%lu" most-positive-fixnum)) most-positive-fixnum)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1452 (Assert (= (read (format "%d" most-negative-fixnum)) most-negative-fixnum)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1453 (Assert (= (read (format "%ld" most-negative-fixnum)) most-negative-fixnum)) |
| 446 | 1454 |
| 4287 | 1455 ;; These used to crash. |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1456 (Assert (eql (read (format "%f" 1.2e+302)) 1.2e+302)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1457 (Assert (eql (read (format "%.1000d" 1)) 1)) |
| 4287 | 1458 |
| 446 | 1459 ;;; "%u" is undocumented, and Emacs Lisp has no unsigned type. |
| 1460 ;;; What to do if "%u" is used with a negative number? | |
| 1983 | 1461 ;;; For non-bignum XEmacsen, the most reasonable thing seems to be to print an |
| 1462 ;;; un-read-able number. The printed value might be useful to a human, if not | |
| 1463 ;;; to Emacs Lisp. | |
| 1464 ;;; For bignum XEmacsen, we make %u with a negative value throw an error. | |
| 1465 (if (featurep 'bignum) | |
| 1466 (progn | |
| 1467 (Check-Error wrong-type-argument (format "%u" most-negative-fixnum)) | |
| 1468 (Check-Error wrong-type-argument (format "%u" -1))) | |
| 1469 (Check-Error invalid-read-syntax (read (format "%u" most-negative-fixnum))) | |
| 1470 (Check-Error invalid-read-syntax (read (format "%u" -1)))) | |
| 448 | 1471 |
| 1472 ;; Check all-completions ignore element start with space. | |
| 1473 (Assert (not (all-completions "" '((" hidden" . "object"))))) | |
| 1474 (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
|
1475 |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1476 (let* ((literal-with-uninterned |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1477 '(first-element |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1478 [#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
|
1479 #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
|
1480 #5=#:G32970 #6=#:G32972])) |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1481 (print-readably t) |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1482 (print-gensym t) |
|
5560
58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5553
diff
changeset
|
1483 (print-continuous-numbering t) |
|
4394
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1484 (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
|
1485 (awkward-regexp "#1=#") |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1486 (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
|
1487 printed-with-uninterned))) |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1488 (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
|
1489 (1+ first-match-start))))) |
|
4580
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4575
diff
changeset
|
1490 |
|
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4575
diff
changeset
|
1491 (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
|
1492 (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
|
1493 (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
|
1494 (prin1-to-string char-table-with-symbol))) |
|
4580
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4575
diff
changeset
|
1495 "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
|
1496 |
|
4608
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1497 |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1498 (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
|
1499 (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
|
1500 nil ".el"))) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1501 (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
|
1502 (erase-buffer) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1503 (insert |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1504 "\ |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1505 ;; 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
|
1506 ;; 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
|
1507 (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
|
1508 |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1509 ;; 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
|
1510 (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
|
1511 old-char) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1512 (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
|
1513 (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
|
1514 (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
|
1515 (aset load-file-name 0 new-char) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1516 (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
|
1517 \"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
|
1518 |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1519 (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
|
1520 (load-file-name new-load-file-name)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1521 (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
|
1522 \"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
|
1523 |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1524 ") |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1525 (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
|
1526 (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
|
1527 (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
|
1528 (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
|
1529 (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
|
1530 |
|
5576
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1531 (labels ((cl-floor (x &optional y) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1532 (let ((q (floor x y))) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1533 (list q (- x (if y (* y q) q))))) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1534 (cl-ceiling (x &optional y) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1535 (let ((res (cl-floor x y))) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1536 (if (= (car (cdr res)) 0) res |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1537 (list (1+ (car res)) (- (car (cdr res)) (or y 1)))))) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1538 (cl-truncate (x &optional y) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1539 (if (eq (>= x 0) (or (null y) (>= y 0))) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1540 (cl-floor x y) (cl-ceiling x y))) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1541 (cl-round (x &optional y) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1542 (if y |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1543 (if (and (integerp x) (integerp y)) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1544 (let* ((hy (/ y 2)) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1545 (res (cl-floor (+ x hy) y))) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1546 (if (and (= (car (cdr res)) 0) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1547 (= (+ hy hy) y) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1548 (/= (% (car res) 2) 0)) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1549 (list (1- (car res)) hy) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1550 (list (car res) (- (car (cdr res)) hy)))) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1551 (let ((q (round (/ x y)))) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1552 (list q (- x (* q y))))) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1553 (if (integerp x) (list x 0) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1554 (let ((q (round x))) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
1555 (list q (- x q)))))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1556 (Assert-rounding (first second &key |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1557 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
|
1558 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
|
1559 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
|
1560 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
|
1561 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
|
1562 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
|
1563 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
|
1564 one-ftruncate-result two-ftruncate-result) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1565 (Assert (equal one-floor-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1566 (floor first))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1567 (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
|
1568 first one-floor-result)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1569 (Assert (equal one-floor-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1570 (floor first 1))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1571 (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
|
1572 first one-floor-result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1573 (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
|
1574 (Check-Error arith-error (floor first 0.0)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1575 (Assert (equal two-floor-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1576 (floor first second))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1577 (format |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1578 "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
|
1579 first second two-floor-result)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1580 (Assert (equal (cl-floor first second) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1581 (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
|
1582 (format |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1583 "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
|
1584 first second)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1585 (Assert (equal one-ffloor-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1586 (ffloor first))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1587 (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
|
1588 first one-ffloor-result)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1589 (Assert (equal one-ffloor-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1590 (ffloor first 1))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1591 (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
|
1592 first one-ffloor-result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1593 (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
|
1594 (Check-Error arith-error (ffloor first 0.0)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1595 (Assert (equal two-ffloor-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1596 (ffloor first second))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1597 (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
|
1598 first second two-ffloor-result)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1599 (Assert (equal one-ceiling-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1600 (ceiling first))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1601 (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
|
1602 first one-ceiling-result)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1603 (Assert (equal one-ceiling-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1604 (ceiling first 1))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1605 (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
|
1606 first one-ceiling-result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1607 (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
|
1608 (Check-Error arith-error (ceiling first 0.0)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1609 (Assert (equal two-ceiling-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1610 (ceiling first second))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1611 (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
|
1612 first second two-ceiling-result)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1613 (Assert (equal (cl-ceiling first second) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1614 (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
|
1615 (format |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1616 "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
|
1617 first second)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1618 (Assert (equal one-fceiling-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1619 (fceiling first))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1620 (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
|
1621 first one-fceiling-result)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1622 (Assert (equal one-fceiling-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1623 (fceiling first 1))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1624 (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
|
1625 first one-fceiling-result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1626 (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
|
1627 (Check-Error arith-error (fceiling first 0.0)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1628 (Assert (equal two-fceiling-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1629 (fceiling first second))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1630 (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
|
1631 first second two-fceiling-result)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1632 (Assert (equal one-round-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1633 (round first))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1634 (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
|
1635 first one-round-result)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1636 (Assert (equal one-round-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1637 (round first 1))) |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
1638 (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
|
1639 first one-round-result)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1640 (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
|
1641 (Check-Error arith-error (round first 0.0)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1642 (Assert (equal two-round-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1643 (round first second))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1644 (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
|
1645 first second two-round-result)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1646 (Assert (equal one-fround-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1647 (fround first))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1648 (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
|
1649 first one-fround-result)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1650 (Assert (equal one-fround-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1651 (fround first 1))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1652 (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
|
1653 first one-fround-result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1654 (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
|
1655 (Check-Error arith-error (fround first 0.0)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1656 (Assert (equal two-fround-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1657 (fround first second))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1658 (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
|
1659 first second two-fround-result)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1660 (Assert (equal (cl-round first second) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1661 (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
|
1662 (format |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1663 "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
|
1664 first second)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1665 (Assert (equal one-truncate-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1666 (truncate first))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1667 (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
|
1668 first one-truncate-result)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1669 (Assert (equal one-truncate-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1670 (truncate first 1))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1671 (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
|
1672 first one-truncate-result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1673 (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
|
1674 (Check-Error arith-error (truncate first 0.0)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1675 (Assert (equal two-truncate-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1676 (truncate first second))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1677 (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
|
1678 first second two-truncate-result)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1679 (Assert (equal (cl-truncate first second) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1680 (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
|
1681 (format |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1682 "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
|
1683 first second)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1684 (Assert (equal one-ftruncate-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1685 (ftruncate first))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1686 (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
|
1687 first one-ftruncate-result)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1688 (Assert (equal one-ftruncate-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1689 (ftruncate first 1))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1690 (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
|
1691 first one-ftruncate-result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1692 (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
|
1693 (Check-Error arith-error (ftruncate first 0.0)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1694 (Assert (equal two-ftruncate-result (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1695 (ftruncate first second))) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1696 (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
|
1697 first second two-ftruncate-result))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1698 (Assert-rounding-floating (pie ee) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1699 (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
|
1700 (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
|
1701 "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
|
1702 (Assert-rounding pie ee |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1703 :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
|
1704 :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
|
1705 :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
|
1706 :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
|
1707 :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
|
1708 :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
|
1709 :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
|
1710 :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
|
1711 :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
|
1712 :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
|
1713 :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
|
1714 :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
|
1715 :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
|
1716 :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
|
1717 :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
|
1718 :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
|
1719 (- pie (* 1.0 ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1720 (Assert-rounding pie (- ee) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1721 :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
|
1722 :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
|
1723 :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
|
1724 :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
|
1725 (- pie (* -2.0 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1726 :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
|
1727 :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
|
1728 :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
|
1729 :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
|
1730 (- pie (* -1.0 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1731 :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
|
1732 :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
|
1733 :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
|
1734 :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
|
1735 (- pie (* -1.0 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1736 :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
|
1737 :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
|
1738 :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
|
1739 :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
|
1740 (- pie (* -1.0 (- ee))))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1741 (Assert-rounding (- pie) ee |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1742 :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
|
1743 :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
|
1744 :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
|
1745 :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
|
1746 (- (- pie) (* -2.0 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1747 :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
|
1748 :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
|
1749 :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
|
1750 :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
|
1751 (- (- pie) (* -1.0 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1752 :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
|
1753 :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
|
1754 :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
|
1755 :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
|
1756 (- (- pie) (* -1.0 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1757 :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
|
1758 :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
|
1759 :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
|
1760 :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
|
1761 (- (- pie) (* -1.0 ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1762 (Assert-rounding (- pie) (- ee) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1763 :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
|
1764 :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
|
1765 :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
|
1766 :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
|
1767 (- (- pie) (* 1.0 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1768 :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
|
1769 :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
|
1770 :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
|
1771 :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
|
1772 (- (- pie) (* 2.0 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1773 :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
|
1774 :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
|
1775 :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
|
1776 :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
|
1777 (- (- pie) (* 1.0 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1778 :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
|
1779 :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
|
1780 :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
|
1781 :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
|
1782 (- (- pie) (* 1.0 (- ee))))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1783 (Assert-rounding ee pie |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1784 :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
|
1785 :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
|
1786 :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
|
1787 :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
|
1788 :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
|
1789 :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
|
1790 :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
|
1791 :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
|
1792 :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
|
1793 :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
|
1794 :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
|
1795 :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
|
1796 :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
|
1797 :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
|
1798 :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
|
1799 :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
|
1800 (Assert-rounding ee (- pie) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1801 :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
|
1802 :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
|
1803 :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
|
1804 :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
|
1805 (- ee (* -1.0 (- pie)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1806 :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
|
1807 :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
|
1808 :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
|
1809 :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
|
1810 :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
|
1811 :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
|
1812 :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
|
1813 :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
|
1814 (- ee (* -1.0 (- pie)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1815 :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
|
1816 :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
|
1817 :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
|
1818 :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
|
1819 ;; First, two integers: |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1820 (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
|
1821 :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
|
1822 :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
|
1823 :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
|
1824 :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
|
1825 :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
|
1826 :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
|
1827 :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
|
1828 (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
|
1829 :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
|
1830 :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
|
1831 :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
|
1832 :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
|
1833 :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
|
1834 :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
|
1835 :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
|
1836 (Assert-rounding -27 8 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1837 :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
|
1838 :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
|
1839 :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
|
1840 :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
|
1841 :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
|
1842 :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
|
1843 :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
|
1844 :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
|
1845 (Assert-rounding -27 -8 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1846 :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
|
1847 :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
|
1848 :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
|
1849 :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
|
1850 :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
|
1851 :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
|
1852 :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
|
1853 :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
|
1854 (Assert-rounding 8 27 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1855 :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
|
1856 :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
|
1857 :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
|
1858 :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
|
1859 :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
|
1860 :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
|
1861 :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
|
1862 :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
|
1863 (Assert-rounding 8 -27 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1864 :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
|
1865 :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
|
1866 :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
|
1867 :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
|
1868 :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
|
1869 :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
|
1870 :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
|
1871 :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
|
1872 (Assert-rounding -8 27 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1873 :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
|
1874 :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
|
1875 :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
|
1876 :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
|
1877 :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
|
1878 :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
|
1879 :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
|
1880 :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
|
1881 (Assert-rounding -8 -27 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1882 :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
|
1883 :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
|
1884 :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
|
1885 :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
|
1886 :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
|
1887 :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
|
1888 :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
|
1889 :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
|
1890 (Assert-rounding 32 4 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1891 :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
|
1892 :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
|
1893 :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
|
1894 :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
|
1895 :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
|
1896 :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
|
1897 :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
|
1898 :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
|
1899 (Assert-rounding 32 -4 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1900 :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
|
1901 :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
|
1902 :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
|
1903 :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
|
1904 :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
|
1905 :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
|
1906 :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
|
1907 :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
|
1908 (Assert-rounding 12 9 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1909 :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
|
1910 :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
|
1911 :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
|
1912 :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
|
1913 :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
|
1914 :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
|
1915 :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
|
1916 :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
|
1917 (Assert-rounding 10 4 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1918 :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
|
1919 :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
|
1920 :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
|
1921 :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
|
1922 :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
|
1923 :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
|
1924 :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
|
1925 :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
|
1926 (Assert-rounding 14 4 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1927 :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
|
1928 :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
|
1929 :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
|
1930 :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
|
1931 :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
|
1932 :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
|
1933 :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
|
1934 :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
|
1935 ;; Now, two floats: |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1936 (Assert-rounding-floating pi e) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1937 (when (featurep 'bigfloat) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1938 (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
|
1939 (when (featurep 'bignum) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1940 (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
|
1941 "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
|
1942 (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
|
1943 :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
|
1944 :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
|
1945 :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
|
1946 :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
|
1947 :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
|
1948 :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
|
1949 :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
|
1950 :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
|
1951 :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
|
1952 :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
|
1953 :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
|
1954 :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
|
1955 :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
|
1956 :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
|
1957 :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
|
1958 :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
|
1959 (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
|
1960 :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
|
1961 :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
|
1962 :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
|
1963 :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
|
1964 :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
|
1965 :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
|
1966 :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
|
1967 :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
|
1968 :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
|
1969 :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
|
1970 :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
|
1971 :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
|
1972 :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
|
1973 :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
|
1974 :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
|
1975 :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
|
1976 (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
|
1977 :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
|
1978 :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
|
1979 :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
|
1980 :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
|
1981 :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
|
1982 :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
|
1983 :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
|
1984 :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
|
1985 :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
|
1986 :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
|
1987 :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
|
1988 :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
|
1989 :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
|
1990 :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
|
1991 :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
|
1992 :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
|
1993 ;; 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
|
1994 (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
|
1995 :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
|
1996 :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
|
1997 :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
|
1998 ;; 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
|
1999 ;; 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
|
2000 ;; 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
|
2001 ;; 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
|
2002 ;; 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
|
2003 :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
|
2004 :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
|
2005 :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
|
2006 :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
|
2007 :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
|
2008 :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
|
2009 :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
|
2010 :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
|
2011 :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
|
2012 :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
|
2013 :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
|
2014 :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
|
2015 ;; 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
|
2016 :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
|
2017 (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
|
2018 :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
|
2019 :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
|
2020 :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
|
2021 ;; 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
|
2022 :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
|
2023 :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
|
2024 :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
|
2025 :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
|
2026 :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
|
2027 :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
|
2028 :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
|
2029 :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
|
2030 :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
|
2031 :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
|
2032 :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
|
2033 :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
|
2034 ;; See commentary above |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2035 :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
|
2036 1))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2037 (when (featurep 'ratio) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2038 (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
|
2039 :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
|
2040 :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
|
2041 :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
|
2042 :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
|
2043 :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
|
2044 :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
|
2045 :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
|
2046 :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
|
2047 (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
|
2048 :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
|
2049 :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
|
2050 :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
|
2051 :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
|
2052 :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
|
2053 :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
|
2054 :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
|
2055 :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
|
2056 |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2057 ;; 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
|
2058 ;; 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
|
2059 ;; 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
|
2060 ;; output here. |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2061 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2062 (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
|
2063 (let ((print-readably t)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2064 (princ first) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2065 (princ " ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2066 (princ second) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2067 (princ " :one-floor-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2068 (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
|
2069 (princ " :two-floor-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2070 (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
|
2071 (princ " :one-ffloor-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2072 (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
|
2073 (princ " :two-ffloor-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2074 (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
|
2075 (princ " :one-ceiling-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2076 (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
|
2077 (princ " :two-ceiling-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2078 (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
|
2079 (princ " :one-fceiling-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2080 (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
|
2081 (princ " :two-fceiling-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2082 (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
|
2083 (princ " :one-round-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2084 (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
|
2085 (princ " :two-round-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2086 (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
|
2087 (princ " :one-fround-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2088 (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
|
2089 (princ " :two-fround-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2090 (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
|
2091 (princ " :one-truncate-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2092 (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
|
2093 (princ " :two-truncate-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2094 (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
|
2095 (princ " :one-ftruncate-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2096 (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
|
2097 (princ " :two-ftruncate-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2098 (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
|
2099 |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2100 ;; Multiple value tests. |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2101 |
|
5576
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2102 (labels ((foo (x y) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2103 (floor (+ x y) y)) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2104 (foo-zero (x y) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2105 (values (floor (+ x y) y))) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2106 (multiple-value-function-returning-t () |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2107 (values t pi e degrees-to-radians radians-to-degrees)) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2108 (multiple-value-function-returning-nil () |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2109 (values nil pi e radians-to-degrees degrees-to-radians)) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2110 (function-throwing-multiple-values () |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2111 (let* ((listing '(0 3 4 nil "string" symbol)) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2112 (tail listing) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2113 elt) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2114 (while t |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2115 (setq tail (cdr listing) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2116 elt (car listing) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2117 listing tail) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2118 (when (null elt) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2119 (throw 'VoN61Lo4Y (multiple-value-function-returning-t))))))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2120 (Assert |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2121 (= (+ (floor 5 3) (floor 19 4)) (+ 1 4) 5) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2122 "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
|
2123 (Assert |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2124 (= 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
|
2125 "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
|
2126 (Assert |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2127 (= 1 (length (multiple-value-list |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2128 (foo-zero 400 (1+ most-positive-fixnum))))) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2129 "Checking multiple values are discarded correctly when forced") |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2130 (Check-Error setting-constant (setq multiple-values-limit 20)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2131 (Assert (equal '(-1 1) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2132 (multiple-value-list (floor -3 4))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2133 "Checking #'multiple-value-list gives a sane result") |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2134 (let ((ey 40000) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2135 (bee "this is a string") |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2136 (cee #s(hash-table size 256 data (969 ?\xF9)))) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2137 (Assert (equal |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2138 (multiple-value-list (values ey bee cee)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2139 (multiple-value-list (values-list (list ey bee cee)))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2140 "Checking that #'values and #'values-list are correctly related") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2141 (Assert (equal |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2142 (multiple-value-list (values-list (list ey bee cee))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2143 (multiple-value-list (apply #'values (list ey bee cee)))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2144 "Checking #'values-list and #'apply with #values are correctly related")) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2145 (Assert (= (multiple-value-call #'+ (floor 5 3) (floor 19 4)) 10) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2146 "Checking #'multiple-value-call gives reasonable results.") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2147 (Assert (= (multiple-value-call (values '+ '*) (floor 5 3) (floor 19 4)) 10) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2148 "Checking #'multiple-value-call correct when first arg multiple.") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2149 (Assert (= 1 (length (multiple-value-list (prog1 (floor pi) "hi there")))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2150 "Checking #'prog1 does not pass back multiple values") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2151 (Assert (= 2 (length (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2152 (multiple-value-prog1 (floor pi) "hi there")))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2153 "Checking #'multiple-value-prog1 passes back multiple values") |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2154 (multiple-value-bind (floored remainder this-is-nil) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2155 (floor pi 1.0) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2156 (Assert (= floored 3) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2157 "Checking floored bound correctly") |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2158 (Assert (eql remainder (- pi 3.0)) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2159 "Checking remainder bound correctly") |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2160 (Assert (null this-is-nil) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2161 "Checking trailing arg bound but nil")) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2162 (let ((ey 40000) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2163 (bee "this is a string") |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2164 (cee #s(hash-table size 256 data (969 ?\xF9)))) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2165 (multiple-value-setq (ey bee cee) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2166 (ffloor e 1.0)) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2167 (Assert (eql 2.0 ey) "Checking ey set correctly") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2168 (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
|
2169 (Assert (null cee) "Checking cee set to nil correctly")) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2170 (Assert (= 3 (length (multiple-value-list (eval '(values nil t pi))))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2171 "Checking #'eval passes back multiple values") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2172 (Assert (= 2 (length (multiple-value-list (apply #'floor '(5 3))))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2173 "Checking #'apply passes back multiple values") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2174 (Assert (= 2 (length (multiple-value-list (funcall #'floor 5 3)))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2175 "Checking #'funcall passes back multiple values") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2176 (Assert (equal '(1 2) (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2177 (multiple-value-call #'floor (values 5 3)))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2178 "Checking #'multiple-value-call passes back multiple values correctly") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2179 (Assert (= 1 (length (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2180 (and (multiple-value-function-returning-nil) t)))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2181 "Checking multiple values from non-trailing forms discarded by #'and") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2182 (Assert (= 5 (length (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2183 (and t (multiple-value-function-returning-nil))))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2184 "Checking multiple values from final forms not discarded by #'and") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2185 (Assert (= 1 (length (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2186 (or (multiple-value-function-returning-t) t)))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2187 "Checking multiple values from non-trailing forms discarded by #'and") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2188 (Assert (= 5 (length (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2189 (or nil (multiple-value-function-returning-t))))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2190 "Checking multiple values from final forms not discarded by #'and") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2191 (Assert (= 1 (length (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2192 (cond ((multiple-value-function-returning-t)))))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2193 "Checking cond doesn't pass back multiple values in tests.") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2194 (Assert (equal (list nil pi e radians-to-degrees degrees-to-radians) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2195 (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2196 (cond (t (multiple-value-function-returning-nil))))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2197 "Checking cond passes back multiple values in clauses.") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2198 (Assert (= 1 (length (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2199 (prog1 (multiple-value-function-returning-nil))))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2200 "Checking prog1 discards multiple values correctly.") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2201 (Assert (= 5 (length (multiple-value-list |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2202 (multiple-value-prog1 |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2203 (multiple-value-function-returning-nil))))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2204 "Checking multiple-value-prog1 passes back multiple values correctly.") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2205 (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
|
2206 (multiple-value-list |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2207 (catch 'VoN61Lo4Y (function-throwing-multiple-values))))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2208 (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
|
2209 (multiple-value-list |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2210 (loop |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2211 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
|
2212 do (when (null eye) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2213 (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
|
2214 "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
|
2215 (Assert |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
2216 (null (or)) |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
2217 "Checking #'or behaves correctly with zero arguments.") |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2218 (Assert (eq t (and)) |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
2219 "Checking #'and behaves correctly with zero arguments.") |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2220 (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
|
2221 (letf (((values three one-four-one-five-nine) (floor pi))) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2222 (* 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
|
2223 "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
|
2224 |
|
4792
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2225 ;; #'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
|
2226 (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
|
2227 (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
|
2228 (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
|
2229 (+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
|
2230 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
|
2231 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
|
2232 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
|
2233 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
|
2234 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
|
2235 |
|
5188
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2236 (macrolet |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2237 ((equalp-equal-list-tests (equal-list) |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2238 (let (res) |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2239 (setq equal-lists (eval equal-list)) |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2240 (loop for li in equal-lists do |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2241 (loop for (x . tail) on li do |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2242 (loop for y in tail do |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2243 (push `(Assert (equalp ,(quote-maybe x) |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2244 ,(quote-maybe y))) res) |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2245 (push `(Assert (equalp ,(quote-maybe y) |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2246 ,(quote-maybe x))) res) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2247 (push `(Assert (eql (equalp-hash ,(quote-maybe y)) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2248 (equalp-hash ,(quote-maybe x)))) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2249 res)))) |
|
5188
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2250 (cons 'progn (nreverse res)))) |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2251 (equalp-diff-list-tests (diff-list) |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2252 (let (res) |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2253 (setq diff-list (eval diff-list)) |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2254 (loop for (x . tail) on diff-list do |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2255 (loop for y in tail do |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2256 (push `(Assert (not (equalp ,(quote-maybe x) |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2257 ,(quote-maybe y)))) res) |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2258 (push `(Assert (not (equalp ,(quote-maybe y) |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2259 ,(quote-maybe x)))) res))) |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2260 (cons 'progn (nreverse res)))) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2261 (Assert-equalp (object-one object-two &optional failing-case description) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2262 `(progn |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2263 (Assert (equalp ,object-one ,object-two) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2264 ,@(if failing-case |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2265 (list failing-case description))) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2266 (Assert (eql (equalp-hash ,object-one) (equalp-hash ,object-two)))))) |
|
5188
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2267 (equalp-equal-list-tests |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2268 `(,@(when (featurep 'bignum) |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2269 (read "((111111111111111111111111111111111111111111111111111 |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2270 111111111111111111111111111111111111111111111111111.0))")) |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2271 (0 0.0 0.000 -0 -0.0 -0.000 #b0 ,@(when (featurep 'ratio) '(0/5 -0/5))) |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2272 (21845 #b101010101010101 #x5555) |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2273 (1.5 1.500000000000000000000000000000000000000000000000000000000 |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2274 ,@(when (featurep 'ratio) '(3/2))) |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2275 ;; Can't use this, these values aren't `='. |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2276 ;;(-12345678901234567890123457890123457890123457890123457890123457890 |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2277 ;; -12345678901234567890123457890123457890123457890123457890123457890.0) |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2278 (-55 -55.000 ,@(when (featurep 'ratio) '(-110/2))))) |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2279 (equalp-diff-list-tests |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2280 `(0 1 2 3 1000 5000000000 |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2281 ,@(when (featurep 'bignum) |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2282 (read "(5555555555555555555555555555555555555 |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2283 -5555555555555555555555555555555555555)")) |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2284 -1 -2 -3 -1000 -5000000000 |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2285 1/2 1/3 2/3 8/2 355/113 |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2286 ,@(when (featurep 'ratio) (mapcar* #'/ '(3/2 3/2) '(0.2 0.7))) |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2287 55555555555555555555555555555555555555555/2718281828459045 |
|
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2288 0.111111111111111111111111111111111111111111111111111111111111111 |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2289 1e+300 1e+301 -1e+300 -1e+301)) |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2290 |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2291 (Assert-equalp "hi there" "Hi There" |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2292 "checking equalp isn't case-sensitive") |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2293 (Assert-equalp |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2294 99 99.0 |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2295 "checking equalp compares numerical values of different types") |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2296 (Assert (null (equalp 99 ?c)) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2297 "checking equalp does not convert characters to numbers") |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2298 ;; Fixed in Hg d0ea57eb3de4. |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2299 (Assert (null (equalp "hi there" [hi there])) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2300 "checking equalp doesn't error with string and non-string") |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2301 (Assert-equalp |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2302 "ABCDEEFGH\u00CDJ" string-variable |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2303 "checking #'equalp is case-insensitive with an upcased constant") |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2304 (Assert-equalp |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2305 "abcdeefgh\xedj" string-variable |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2306 "checking #'equalp is case-insensitive with a downcased constant") |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2307 (Assert-equalp string-variable string-variable |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2308 "checking #'equalp works when handed the same string twice") |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2309 (Assert (equalp string-variable "aBcDeeFgH\u00Edj") |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2310 "check #'equalp is case-insensitive with a variable-cased constant") |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2311 (Assert-equalp "" (bit-vector) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2312 "check empty string and empty bit-vector are #'equalp.") |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2313 (Assert-equalp |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2314 (string) (bit-vector) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2315 "check empty string and empty bit-vector are #'equalp, no constants") |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2316 (Assert-equalp "hi there" (vector ?h ?i ?\ ?t ?h ?e ?r ?e) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2317 "check string and vector with same contents #'equalp") |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2318 (Assert-equalp |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2319 (string ?h ?i ?\ ?t ?h ?e ?r ?e) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2320 (vector ?h ?i ?\ ?t ?h ?e ?r ?e) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2321 "check string and vector with same contents #'equalp, no constants") |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2322 (Assert-equalp |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2323 [?h ?i ?\ ?t ?h ?e ?r ?e] |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2324 (string ?h ?i ?\ ?t ?h ?e ?r ?e) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2325 "check string and vector with same contents #'equalp, vector constant") |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2326 (Assert-equalp [0 1.0 0.0 0 1] |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2327 (bit-vector 0 1 0 0 1) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2328 "check vector and bit-vector with same contents #'equalp,\ |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2329 vector constant") |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2330 (Assert (not (equalp [0 2 0.0 0 1] |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2331 (bit-vector 0 1 0 0 1))) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2332 "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
|
2333 vector constant") |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2334 (Assert-equalp #*01001 |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2335 (vector 0 1.0 0.0 0 1) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2336 "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
|
2337 bit-vector constant") |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2338 (Assert-equalp ?\u00E9 Eacute-character |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2339 "checking characters are case-insensitive, one constant") |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2340 (Assert (not (equalp ?\u00E9 (aref (format "%c" ?a) 0))) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2341 "checking distinct characters are not equalp, one constant") |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2342 (Assert-equalp t (and) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2343 "checking symbols are correctly #'equalp") |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2344 (Assert (not (equalp t (or nil '#:t))) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2345 "checking distinct symbols with the same name are not #'equalp") |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2346 (Assert-equalp #s(char-table type generic data (?\u0080 "hi-there")) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2347 (let ((aragh (make-char-table 'generic))) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2348 (put-char-table ?\u0080 "hi-there" aragh) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2349 aragh) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2350 "checking #'equalp succeeds correctly, char-tables") |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2351 (Assert-equalp #s(char-table type generic data (?\u0080 "hi-there")) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2352 (let ((aragh (make-char-table 'generic))) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2353 (put-char-table ?\u0080 "HI-THERE" aragh) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2354 aragh) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2355 "checking #'equalp succeeds correctly, char-tables") |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2356 (Assert (not (equalp #s(char-table type generic data (?\u0080 "hi-there")) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2357 (let ((aragh (make-char-table 'generic))) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2358 (put-char-table ?\u0080 "hi there" aragh) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2359 aragh))) |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2360 "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
|
2361 |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2362 ;; 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
|
2363 ;; |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2364 ;; 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
|
2365 ;; |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2366 ;; 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
|
2367 ;; 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
|
2368 ;; 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
|
2369 ;; 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
|
2370 ;; 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
|
2371 ;; 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
|
2372 |
|
4795
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2373 (loop |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2374 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
|
2375 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
|
2376 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
|
2377 do |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2378 (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
|
2379 (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
|
2380 (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
|
2381 (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
|
2382 (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
|
2383 (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
|
2384 (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
|
2385 (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
|
2386 |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2387 (loop |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2388 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
|
2389 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
|
2390 (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
|
2391 |
|
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2392 ;; #'member, #'assoc tests. |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2393 |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2394 (when (featurep 'bignum) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2395 (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
|
2396 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
|
2397 (assoc*-list (loop |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2398 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
|
2399 collect (cons elt (random)))) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2400 (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
|
2401 hashed-bignum) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2402 (macrolet |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2403 ((1+most-positive-fixnum () |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2404 (1+ most-positive-fixnum)) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2405 (1-most-negative-fixnum () |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2406 (1- most-negative-fixnum)) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2407 (*-2-most-positive-fixnum () |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2408 (* 2 most-positive-fixnum))) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2409 (Assert (eq |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2410 (member* (1+ most-positive-fixnum) member*-list) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2411 (member* (1+ most-positive-fixnum) member*-list :test #'eql)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2412 "checking #'member* correct if #'eql not explicitly specified") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2413 (Assert (eq |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2414 (assoc* (1+ most-positive-fixnum) assoc*-list) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2415 (assoc* (1+ most-positive-fixnum) assoc*-list :test #'eql)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2416 "checking #'assoc* correct if #'eql not explicitly specified") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2417 (Assert (eq |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2418 (rassoc* (1- most-negative-fixnum) assoc*-list) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2419 (rassoc* (1- most-negative-fixnum) assoc*-list :test #'eql)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2420 "checking #'rassoc* correct if #'eql not explicitly specified") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2421 (Assert (eql (1+most-positive-fixnum) (1+ most-positive-fixnum)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2422 "checking #'eql handles a bignum literal properly.") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2423 (Assert (eq |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2424 (member* (1+most-positive-fixnum) member*-list) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2425 (member* (1+ most-positive-fixnum) member*-list :test #'equal)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2426 "checking #'member* compiler macro correct with literal bignum") |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2427 (Assert (eq |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2428 (assoc* (1+most-positive-fixnum) assoc*-list) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2429 (assoc* (1+ most-positive-fixnum) assoc*-list :test #'equal)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2430 "checking #'assoc* compiler macro correct with literal bignum") |
|
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2431 (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
|
2432 (gensym) hashing) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2433 (Assert (eq |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2434 (gethash (* 2 most-positive-fixnum) hashing) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2435 (gethash hashed-bignum hashing)) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2436 "checking hashing works correctly with #'eql tests and bignums")))) |
|
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2437 |
|
5241
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2438 ;; |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2439 (when (decode-char 'ucs #x0192) |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2440 (Check-Error |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2441 invalid-state |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2442 (let ((str "aaaaaaaaaaaaa") |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2443 (called 0) |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2444 modified) |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2445 (reduce #'+ str |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2446 :key #'(lambda (object) |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2447 (prog1 |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2448 object |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2449 (incf called) |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2450 (or modified |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2451 (and (> called 5) |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2452 (setq modified |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2453 (fill str (read #r"?\u0192"))))))))))) |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2454 |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2455 (Assert |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2456 (eql 55 |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2457 (let ((sequence '(1 2 3 4 5 6 7 8 9 10)) |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2458 (called 0) |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2459 modified) |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2460 (reduce #'+ |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2461 sequence |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2462 :key |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2463 #'(lambda (object) (prog1 |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2464 object |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2465 (incf called) |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2466 (and (eql called 5) |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2467 (setcdr (nthcdr 3 sequence) nil)) |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2468 (garbage-collect)))))) |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2469 "checking we can amputate lists without crashing #'reduce") |
|
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2470 |
|
5244
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2471 (Assert (not (eq t (canonicalize-inst-list |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2472 `(((mswindows) . [string :data ,(make-string 20 0)]) |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2473 ((tty) . [string :data " "])) 'image t))) |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2474 "checking mswindows is always available as a specifier tag") |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2475 |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2476 (Assert (not (eq t (canonicalize-inst-list |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2477 `(((mswindows) . [nothing]) |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2478 ((tty) . [string :data " "])) |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2479 'image t))) |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2480 "checking the correct syntax for a nothing image specifier works") |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2481 |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2482 (Check-Error-Message invalid-argument "^Invalid specifier tag set" |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2483 (canonicalize-inst-list |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2484 `(((,(gensym)) . [nothing]) |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2485 ((tty) . [string :data " "])) |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2486 'image)) |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2487 |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2488 (Check-Error-Message invalid-argument "^Unrecognized keyword" |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2489 (canonicalize-inst-list |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2490 `(((mswindows) . [nothing :data "hi there"]) |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2491 ((tty) . [string :data " "])) 'image)) |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2492 |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2493 ;; If we combine both the specifier inst list problems, we get the |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2494 ;; unrecognized keyword error first, not the invalid specifier tag set |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2495 ;; error. This is a little unintuitive; the specifier tag set thing is |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2496 ;; processed first, and would seem to be more important. But anyone writing |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2497 ;; code needs to solve both problems, it's reasonable to ask them to do it |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2498 ;; in series rather than in parallel. |
|
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2499 |
|
5243
808131ba4a57
Print symbols with ratio-like names and the associated ratios distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2500 (when (featurep 'ratio) |
|
808131ba4a57
Print symbols with ratio-like names and the associated ratios distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2501 (Assert (not (eql '1/2 (read (prin1-to-string (intern "1/2"))))) |
|
808131ba4a57
Print symbols with ratio-like names and the associated ratios distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2502 "checking symbols with ratio-like names are printed distinctly") |
|
808131ba4a57
Print symbols with ratio-like names and the associated ratios distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2503 (Assert (not (eql '1/5 (read (prin1-to-string (intern "2/10"))))) |
|
808131ba4a57
Print symbols with ratio-like names and the associated ratios distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2504 "checking symbol named \"2/10\" not eql to ratio 1/5 on read")) |
|
808131ba4a57
Print symbols with ratio-like names and the associated ratios distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2505 |
|
5283
be436ac36ba4
Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5244
diff
changeset
|
2506 (let* ((count 0) |
|
be436ac36ba4
Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5244
diff
changeset
|
2507 (list (map-into (make-list 2048 nil) #'(lambda () (decf count)))) |
|
be436ac36ba4
Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5244
diff
changeset
|
2508 (expected (append list '(1)))) |
|
be436ac36ba4
Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5244
diff
changeset
|
2509 (Assert (equal expected (merge 'list list '(1) #'<)) |
|
be436ac36ba4
Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5244
diff
changeset
|
2510 "checking merge's circularity checks are sane")) |
|
be436ac36ba4
Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5244
diff
changeset
|
2511 |
|
5576
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2512 (labels ((list-nreverse (list) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2513 (do ((list1 list (cdr list1)) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2514 (list2 nil (prog1 list1 (setcdr list1 list2)))) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2515 ((atom list1) list2)))) |
|
5300
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2516 (let* ((integers (loop for i from 0 to 6000 collect i)) |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2517 (characters (mapcan #'(lambda (integer) |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2518 (if (char-int-p integer) |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2519 (list (int-char integer)))) integers)) |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2520 (fourth-bit #'(lambda (integer) (ash (logand #x10 integer) -4))) |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2521 (bits (mapcar fourth-bit integers)) |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2522 (vector (vconcat integers)) |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2523 (string (concat characters)) |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2524 (bit-vector (bvconcat bits))) |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2525 (Assert (equal (reverse vector) |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2526 (vconcat (list-nreverse (copy-list integers))))) |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2527 (Assert (eq vector (nreverse vector))) |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2528 (Assert (equal vector (vconcat (list-nreverse (copy-list integers))))) |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2529 (Assert (equal (reverse string) |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2530 (concat (list-nreverse (copy-list characters))))) |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2531 (Assert (eq string (nreverse string))) |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2532 (Assert (equal string (concat (list-nreverse (copy-list characters))))) |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2533 (Assert (eq bit-vector (nreverse bit-vector))) |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2534 (Assert (equal (bvconcat (list-nreverse (copy-list bits))) bit-vector)) |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2535 (Assert (not (equal bit-vector |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2536 (mapcar fourth-bit |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2537 (loop for i from 0 to 6000 collect i))))))) |
|
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2538 |
|
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2539 (Check-Error wrong-type-argument (self-insert-command 'self-insert-command)) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2540 (Check-Error wrong-type-argument (make-list 'make-list 'make-list)) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2541 (Check-Error wrong-type-argument (make-vector 'make-vector 'make-vector)) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2542 (Check-Error wrong-type-argument (make-bit-vector 'make-bit-vector |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2543 'make-bit-vector)) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2544 (Check-Error wrong-type-argument (make-byte-code '(&rest ignore) "\xc0\x87" [4] |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2545 'ignore)) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2546 (Check-Error wrong-type-argument (make-string ?a ?a)) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2547 (Check-Error wrong-type-argument (nth-value 'nth-value (truncate pi e))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2548 (Check-Error wrong-type-argument (make-hash-table :test #'eql :size :size)) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2549 (Check-Error wrong-type-argument |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2550 (accept-process-output nil 'accept-process-output)) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2551 (Check-Error wrong-type-argument |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2552 (accept-process-output nil 2000 'accept-process-output)) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2553 (Check-Error wrong-type-argument |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2554 (self-insert-command 'self-insert-command)) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2555 (Check-Error wrong-type-argument (string-to-number "16" 'string-to-number)) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2556 (Check-Error wrong-type-argument (move-to-column 'move-to-column)) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2557 (stop-profiling) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2558 (Check-Error wrong-type-argument (start-profiling (float most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2559 (stop-profiling) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2560 (Check-Error wrong-type-argument |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2561 (fill '(1 2 3 4 5) 1 :start (float most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2562 (Check-Error wrong-type-argument |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2563 (fill [1 2 3 4 5] 1 :start (float most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2564 (Check-Error wrong-type-argument |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2565 (fill "1 2 3 4 5" ?1 :start (float most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2566 (Check-Error wrong-type-argument |
|
5323
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2567 (fill #*10101010 1 :start (float most-positive-fixnum))) |
|
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2568 (Check-Error wrong-type-argument |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2569 (fill '(1 2 3 4 5) 1 :end (float most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2570 (Check-Error wrong-type-argument |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2571 (fill [1 2 3 4 5] 1 :end (float most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2572 (Check-Error wrong-type-argument |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2573 (fill "1 2 3 4 5" ?1 :end (float most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2574 (Check-Error wrong-type-argument |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2575 (fill #*10101010 1 :end (float most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2576 (Check-Error wrong-type-argument |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2577 (reduce #'cons '(1 2 3 4 5) :start (float most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2578 (Check-Error wrong-type-argument |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2579 (reduce #'cons [1 2 3 4 5] :start (float most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2580 (Check-Error wrong-type-argument |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2581 (reduce #'cons "1 2 3 4 5" :start (float most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2582 (Check-Error wrong-type-argument |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2583 (reduce #'cons #*10101010 :start (float most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2584 (Check-Error wrong-type-argument |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2585 (reduce #'cons '(1 2 3 4 5) :end (float most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2586 (Check-Error wrong-type-argument |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2587 (reduce #'cons [1 2 3 4 5] :end (float most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2588 (Check-Error wrong-type-argument |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2589 (reduce #'cons "1 2 3 4 5" :end (float most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2590 (Check-Error wrong-type-argument |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2591 (reduce #'cons #*10101010 :end (float most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2592 |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2593 (when (featurep 'bignum) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2594 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2595 (self-insert-command (* 2 most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2596 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2597 (make-list (* 3 most-positive-fixnum) 'make-list)) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2598 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2599 (make-vector (* 4 most-positive-fixnum) 'make-vector)) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2600 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2601 (make-bit-vector (+ 2 most-positive-fixnum) 'make-bit-vector)) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2602 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2603 (make-byte-code '(&rest ignore) "\xc0\x87" [4] |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2604 (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2605 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2606 (make-byte-code '(&rest ignore) "\xc0\x87" [4] |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2607 #x10000)) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2608 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2609 (make-string (* 4 most-positive-fixnum) ?a)) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2610 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2611 (nth-value most-positive-fixnum (truncate pi e))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2612 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2613 (make-hash-table :test #'equalp :size (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2614 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2615 (accept-process-output nil 4294967)) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2616 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2617 (accept-process-output nil 10 (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2618 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2619 (self-insert-command (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2620 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2621 (string-to-number "16" (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2622 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2623 (recent-keys (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2624 (when (featurep 'xbm) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2625 (Check-Error-Message |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2626 invalid-argument |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2627 "^data is too short for width and height" |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2628 (set-face-background-pixmap |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2629 'left-margin |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2630 `[xbm :data (20 ,(* 2 most-positive-fixnum) "random-text")]))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2631 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2632 (move-to-column (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2633 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2634 (move-to-column (1- most-negative-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2635 (stop-profiling) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2636 (when (< most-positive-fixnum (lsh 1 32)) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2637 ;; We only support machines with integers of 32 bits or more. If |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2638 ;; most-positive-fixnum is less than 2^32, we're on a 32-bit machine, |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2639 ;; and it's appropriate to test start-profiling with a bignum. |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2640 (Assert (eq nil (start-profiling (* most-positive-fixnum 2))))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2641 (stop-profiling) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2642 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2643 (fill '(1 2 3 4 5) 1 :start (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2644 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2645 (fill [1 2 3 4 5] 1 :start (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2646 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2647 (fill "1 2 3 4 5" ?1 :start (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2648 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2649 (fill #*10101010 1 :start (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2650 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2651 (fill '(1 2 3 4 5) 1 :end (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2652 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2653 (fill [1 2 3 4 5] 1 :end (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2654 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2655 (fill "1 2 3 4 5" ?1 :end (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2656 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2657 (fill #*10101010 1 :end (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2658 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2659 (reduce #'cons '(1 2 3 4 5) :start (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2660 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2661 (reduce #'cons [1 2 3 4 5] :start (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2662 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2663 (reduce #'cons "1 2 3 4 5" :start (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2664 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2665 (reduce #'cons #*10101010 :start (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2666 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2667 (reduce #'cons '(1 2 3 4 5) :end (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2668 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2669 (reduce #'cons [1 2 3 4 5] :end (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2670 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2671 (reduce #'cons "1 2 3 4 5" :end (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2672 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2673 (reduce #'cons #*10101010 :end (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2674 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2675 (replace '(1 2 3 4 5) [5 4 3 2 1] |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2676 :start1 (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2677 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2678 (replace '(1 2 3 4 5) [5 4 3 2 1] |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2679 :start2 (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2680 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2681 (replace '(1 2 3 4 5) [5 4 3 2 1] |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2682 :end1 (1+ most-positive-fixnum))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2683 (Check-Error args-out-of-range |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2684 (replace '(1 2 3 4 5) [5 4 3 2 1] |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2685 :end2 (1+ most-positive-fixnum)))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2686 |
|
5323
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2687 (symbol-macrolet |
|
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2688 ((list-length 2048) (vector-length 512) (string-length (* 8192 2))) |
|
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2689 (let ((list |
|
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2690 ;; CIRCULAR_LIST_SUSPICION_LENGTH is 1024, it's helpful if this list |
|
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2691 ;; is longer than that. |
|
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2692 (make-list list-length 'make-list)) |
|
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2693 (vector (make-vector vector-length 'make-vector)) |
|
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2694 (bit-vector (make-bit-vector vector-length 1)) |
|
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2695 (string (make-string string-length |
|
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2696 (or (decode-char 'ucs #x20ac) ?\xFF))) |
|
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2697 (item 'cons)) |
|
5347
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2698 (macrolet |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2699 ((construct-item-sequence-checks (&rest functions) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2700 (cons |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2701 'progn |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2702 (mapcan |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2703 #'(lambda (function) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2704 `((Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2705 (,function item list |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2706 :start (1+ list-length) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2707 :end (1+ list-length))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2708 (Check-Error wrong-type-argument |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2709 (,function item list :start -1 |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2710 :end list-length)) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2711 (Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2712 (,function item list :end (* 2 list-length))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2713 (Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2714 (,function item vector |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2715 :start (1+ vector-length) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2716 :end (1+ vector-length))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2717 (Check-Error wrong-type-argument |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2718 (,function item vector :start -1)) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2719 (Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2720 (,function item vector |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2721 :end (* 2 vector-length))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2722 (Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2723 (,function item bit-vector |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2724 :start (1+ vector-length) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2725 :end (1+ vector-length))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2726 (Check-Error wrong-type-argument |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2727 (,function item bit-vector :start -1)) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2728 (Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2729 (,function item bit-vector |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2730 :end (* 2 vector-length))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2731 (Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2732 (,function item string |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2733 :start (1+ string-length) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2734 :end (1+ string-length))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2735 (Check-Error wrong-type-argument |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2736 (,function item string :start -1)) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2737 (Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2738 (,function item string |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2739 :end (* 2 string-length))))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2740 functions))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2741 (construct-one-sequence-checks (&rest functions) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2742 (cons |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2743 'progn |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2744 (mapcan |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2745 #'(lambda (function) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2746 `((Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2747 (,function (copy-sequence list) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2748 :start (1+ list-length) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2749 :end (1+ list-length))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2750 (Check-Error wrong-type-argument |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2751 (,function (copy-sequence list) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2752 :start -1 :end list-length)) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2753 (Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2754 (,function (copy-sequence list) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2755 :end (* 2 list-length))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2756 (Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2757 (,function (copy-sequence vector) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2758 :start (1+ vector-length) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2759 :end (1+ vector-length))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2760 (Check-Error wrong-type-argument |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2761 (,function (copy-sequence vector) :start -1)) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2762 (Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2763 (,function (copy-sequence vector) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2764 :end (* 2 vector-length))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2765 (Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2766 (,function (copy-sequence bit-vector) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2767 :start (1+ vector-length) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2768 :end (1+ vector-length))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2769 (Check-Error wrong-type-argument |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2770 (,function (copy-sequence bit-vector) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2771 :start -1)) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2772 (Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2773 (,function (copy-sequence bit-vector) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2774 :end (* 2 vector-length))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2775 (Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2776 (,function (copy-sequence string) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2777 :start (1+ string-length) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2778 :end (1+ string-length))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2779 (Check-Error wrong-type-argument |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2780 (,function (copy-sequence string) :start -1)) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2781 (Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2782 (,function (copy-sequence string) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2783 :end (* 2 string-length))))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2784 functions))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2785 (construct-two-sequence-checks (&rest functions) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2786 (cons |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2787 'progn |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2788 (mapcan |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2789 #'(lambda (function) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2790 `((Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2791 (,function (copy-sequence list) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2792 (copy-sequence list) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2793 :start1 (1+ list-length) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2794 :end1 (1+ list-length))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2795 (Check-Error wrong-type-argument |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2796 (,function (copy-sequence list) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2797 (copy-sequence list) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2798 :start1 -1 :end1 list-length)) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2799 (Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2800 (,function (copy-sequence list) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2801 (copy-sequence list) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2802 :end1 (* 2 list-length))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2803 (Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2804 (,function (copy-sequence vector) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2805 (copy-sequence vector) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2806 :start1 (1+ vector-length) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2807 :end1 (1+ vector-length))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2808 (Check-Error wrong-type-argument |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2809 (,function |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2810 (copy-sequence vector) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2811 (copy-sequence vector) :start1 -1)) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2812 (Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2813 (,function (copy-sequence vector) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2814 (copy-sequence vector) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2815 :end1 (* 2 vector-length))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2816 (Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2817 (,function (copy-sequence bit-vector) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2818 (copy-sequence bit-vector) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2819 :start1 (1+ vector-length) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2820 :end1 (1+ vector-length))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2821 (Check-Error wrong-type-argument |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2822 (,function (copy-sequence bit-vector) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2823 (copy-sequence bit-vector) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2824 :start1 -1)) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2825 (Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2826 (,function (copy-sequence bit-vector) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2827 (copy-sequence bit-vector) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2828 :end1 (* 2 vector-length))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2829 (Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2830 (,function (copy-sequence string) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2831 (copy-sequence string) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2832 :start1 (1+ string-length) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2833 :end1 (1+ string-length))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2834 (Check-Error wrong-type-argument |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2835 (,function (copy-sequence string) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2836 (copy-sequence string) :start1 -1)) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2837 (Check-Error args-out-of-range |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2838 (,function (copy-sequence string) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2839 (copy-sequence string) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2840 :end1 (* 2 string-length))))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2841 functions)))) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2842 (construct-item-sequence-checks count position find delete* remove* |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2843 reduce) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2844 (construct-one-sequence-checks delete-duplicates remove-duplicates) |
|
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2845 (construct-two-sequence-checks replace mismatch search)))) |
|
5323
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2846 |
|
5336
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2847 (let* ((list (list 1 2 3 4 5 6 7 120 'hi-there '#:everyone)) |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2848 (vector (map 'vector #'identity list)) |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2849 (bit-vector (map 'bit-vector |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2850 #'(lambda (object) (if (fixnump object) 1 0)) list)) |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2851 (string (map 'string |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2852 #'(lambda (object) (or (and (fixnump object) |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2853 (int-char object)) |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2854 (decode-char 'ucs #x20ac))) list)) |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2855 (gensym (gensym))) |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2856 (Assert (null (find 'not-in-it list))) |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2857 (Assert (null (find 'not-in-it vector))) |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2858 (Assert (null (find 'not-in-it bit-vector))) |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2859 (Assert (null (find 'not-in-it string))) |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2860 (loop |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2861 for elt being each element in vector using (index position) |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2862 do |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2863 (Assert (eq elt (find elt list))) |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2864 (Assert (eq (elt list position) (find elt vector)))) |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2865 (Assert (eq gensym (find 'not-in-it list :default gensym))) |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2866 (Assert (eq gensym (find 'not-in-it vector :default gensym))) |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2867 (Assert (eq gensym (find 'not-in-it bit-vector :default gensym))) |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2868 (Assert (eq gensym (find 'not-in-it string :default gensym))) |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2869 (Assert (eq 'hi-there (find 'hi-there list))) |
|
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2870 ;; Different uninterned symbols with the same name. |
|
5339
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2871 (Assert (not (eq '#1=#:everyone (find '#1# list)))) |
|
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2872 |
|
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2873 ;; Test concatenate. |
|
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2874 (Assert (equal list (concatenate 'list vector))) |
|
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2875 (Assert (equal list (concatenate 'list (subseq vector 0 4) |
|
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2876 (subseq list 4)))) |
|
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2877 (Assert (equal vector (concatenate 'vector list))) |
|
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2878 (Assert (equal vector (concatenate `(vector * ,(length vector)) list))) |
|
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2879 (Assert (equal string (concatenate `(vector character ,(length string)) |
|
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2880 (append string nil)))) |
|
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2881 (Assert (equal bit-vector (concatenate 'bit-vector (subseq bit-vector 0 4) |
|
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2882 (append (subseq bit-vector 4) nil)))) |
|
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2883 (Assert (equal bit-vector (concatenate `(vector bit ,(length bit-vector)) |
|
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2884 (subseq bit-vector 0 4) |
|
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2885 (append (subseq bit-vector 4) nil))))) |
|
5336
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2886 |
|
5353
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2887 ;;----------------------------------------------------- |
|
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2888 ;; Test `block', `return-from' |
|
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2889 ;;----------------------------------------------------- |
|
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2890 (Assert (eql 1 (block outer |
|
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2891 (flet ((outtahere (n) (return-from outer n))) |
|
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2892 (block outer (outtahere 1))) |
|
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2893 2)) |
|
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2894 "checking `block' and `return-from' are lexically scoped correctly") |
|
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2895 |
|
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2896 ;; Other tests are available in Paul Dietz' test suite, and pass. The above, |
|
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2897 ;; which we used to fail, is based on a test in the Hyperspec. We still |
|
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2898 ;; behave incorrectly when compiled for the contorted-example function of |
|
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2899 ;; CLTL2, whence the following test: |
|
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2900 |
|
5576
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2901 (labels ((needs-lexical-context (first second third) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2902 (if (eql 0 first) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2903 (funcall second) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2904 (block awkward |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2905 (+ 5 (needs-lexical-context |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2906 (1- first) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2907 third |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2908 #'(lambda () (return-from awkward 0))) |
|
071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5574
diff
changeset
|
2909 first))))) |
|
5595
391d809fa4e9
Update tests that have started failing because of changed design decisions.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5576
diff
changeset
|
2910 (Known-Bug-Expect-Failure |
|
391d809fa4e9
Update tests that have started failing because of changed design decisions.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5576
diff
changeset
|
2911 (Assert (eql 0 (needs-lexical-context 2 nil nil)) |
|
391d809fa4e9
Update tests that have started failing because of changed design decisions.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5576
diff
changeset
|
2912 "the function special operator doesn't create a lexical context."))) |
|
5353
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2913 |
|
5462
97ac18bd1fa3
Make sure distinct symbol macros with identical names expand distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5374
diff
changeset
|
2914 ;; Test symbol-macrolet with symbols with identical string names. |
|
97ac18bd1fa3
Make sure distinct symbol macros with identical names expand distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5374
diff
changeset
|
2915 |
|
97ac18bd1fa3
Make sure distinct symbol macros with identical names expand distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5374
diff
changeset
|
2916 (macrolet |
|
97ac18bd1fa3
Make sure distinct symbol macros with identical names expand distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5374
diff
changeset
|
2917 ((test-symbol-macrolet () |
|
97ac18bd1fa3
Make sure distinct symbol macros with identical names expand distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5374
diff
changeset
|
2918 (let* ((symbol 'my-symbol) |
|
97ac18bd1fa3
Make sure distinct symbol macros with identical names expand distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5374
diff
changeset
|
2919 (copy-symbol (copy-symbol symbol)) |
|
97ac18bd1fa3
Make sure distinct symbol macros with identical names expand distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5374
diff
changeset
|
2920 (third (copy-symbol copy-symbol))) |
|
97ac18bd1fa3
Make sure distinct symbol macros with identical names expand distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5374
diff
changeset
|
2921 `(symbol-macrolet ((,symbol [symbol expansion]) |
|
97ac18bd1fa3
Make sure distinct symbol macros with identical names expand distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5374
diff
changeset
|
2922 (,copy-symbol [copy expansion]) |
|
97ac18bd1fa3
Make sure distinct symbol macros with identical names expand distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5374
diff
changeset
|
2923 (,third [third expansion])) |
|
97ac18bd1fa3
Make sure distinct symbol macros with identical names expand distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5374
diff
changeset
|
2924 (list ,symbol ,copy-symbol ,third))))) |
|
97ac18bd1fa3
Make sure distinct symbol macros with identical names expand distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5374
diff
changeset
|
2925 (Assert (equal '([symbol expansion] [copy expansion] [third expansion]) |
|
97ac18bd1fa3
Make sure distinct symbol macros with identical names expand distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5374
diff
changeset
|
2926 (test-symbol-macrolet)))) |
|
97ac18bd1fa3
Make sure distinct symbol macros with identical names expand distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5374
diff
changeset
|
2927 |
|
5550
b908c7265a2b
Add the #'apply-partially API, as used by GNU.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5476
diff
changeset
|
2928 ;; Basic tests of #'apply-partially. |
|
b908c7265a2b
Add the #'apply-partially API, as used by GNU.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5476
diff
changeset
|
2929 (let* ((four 4) |
|
b908c7265a2b
Add the #'apply-partially API, as used by GNU.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5476
diff
changeset
|
2930 (times-four (apply-partially '* four)) |
|
5553
62edcc6a11ec
Add an assertion about argument order to #'apply-partially compiler macro
Aidan Kehoe <kehoea@parhasard.net>
parents:
5550
diff
changeset
|
2931 (plus-twelve (apply-partially '+ 6 (* 3 2))) |
|
62edcc6a11ec
Add an assertion about argument order to #'apply-partially compiler macro
Aidan Kehoe <kehoea@parhasard.net>
parents:
5550
diff
changeset
|
2932 (construct-list (apply-partially 'list (incf four) (incf four) |
|
62edcc6a11ec
Add an assertion about argument order to #'apply-partially compiler macro
Aidan Kehoe <kehoea@parhasard.net>
parents:
5550
diff
changeset
|
2933 (incf four)))) |
|
5550
b908c7265a2b
Add the #'apply-partially API, as used by GNU.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5476
diff
changeset
|
2934 (Assert (eql (funcall times-four 6) 24)) |
|
b908c7265a2b
Add the #'apply-partially API, as used by GNU.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5476
diff
changeset
|
2935 (Assert (eql (funcall times-four 4 4) 64)) |
|
b908c7265a2b
Add the #'apply-partially API, as used by GNU.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5476
diff
changeset
|
2936 (Assert (eql (funcall plus-twelve (funcall times-four 4) 4 4) 36)) |
|
5553
62edcc6a11ec
Add an assertion about argument order to #'apply-partially compiler macro
Aidan Kehoe <kehoea@parhasard.net>
parents:
5550
diff
changeset
|
2937 (Check-Error wrong-number-of-arguments (apply-partially)) |
|
62edcc6a11ec
Add an assertion about argument order to #'apply-partially compiler macro
Aidan Kehoe <kehoea@parhasard.net>
parents:
5550
diff
changeset
|
2938 (Assert (equal (funcall construct-list) '(5 6 7)))) |
|
5550
b908c7265a2b
Add the #'apply-partially API, as used by GNU.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5476
diff
changeset
|
2939 |
|
5574
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2940 ;; Test labels and inlining. |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2941 (labels |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2942 ((+ (&rest arguments) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2943 ;; Shades of Java, hah. |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2944 (mapconcat #'prin1-to-string arguments ", ")) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2945 (print-with-commas (stream one two three four five) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2946 (princ (+ one two three four five) stream)) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2947 (bookend (open close &rest arguments) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2948 (refer-to-bookend (concat open (apply #'+ arguments) close))) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2949 (refer-to-bookend (string) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2950 (bookend "[" "]" string "hello" "there"))) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2951 (declare (inline + print-with-commas bookend refer-to-bookend)) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2952 (macrolet |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2953 ((with-first-arguments (&optional form) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2954 (append form (list 1 [hi there] 40 "this is a string" pi))) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2955 (with-second-arguments (&optional form) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2956 (append form (list pi e ''hello ''there [40 50 60]))) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2957 (with-both-arguments (&optional form) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2958 (append form |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2959 (macroexpand '(with-first-arguments)) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2960 (macroexpand '(with-second-arguments))))) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2961 |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2962 (with-temp-buffer |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2963 (Assert |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2964 (equal |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2965 (mapconcat #'prin1-to-string (with-first-arguments (list)) ", ") |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2966 (with-first-arguments (print-with-commas (current-buffer)))) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2967 "checking print-with-commas gives the expected result") |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2968 (Assert |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2969 (or |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2970 (not (compiled-function-p (indirect-function #'print-with-commas))) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2971 (notany #'compiled-function-p |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2972 (compiled-function-constants |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2973 (indirect-function #'print-with-commas)))) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2974 "checking the label + was inlined correctly") |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2975 (insert ", ") |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2976 ;; This call to + will be inline in compiled code, but there's |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2977 ;; no easy way for us to check that: |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2978 (Assert (null (insert (with-second-arguments (+))))) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2979 (Assert (equal |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2980 (mapconcat #'prin1-to-string (with-both-arguments (list)) ", ") |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2981 (buffer-string)) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2982 "checking the buffer contents are as expected at the end.") |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2983 (Assert (not (funcall (intern "eq") #'bookend #'refer-to-bookend)) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2984 "checking two mutually recursive functions compiled OK")))) |
|
d4f334808463
Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2985 |
|
4732
2491a837112c
Fix typo in test of equalp and add more tests.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4728
diff
changeset
|
2986 ;;; end of lisp-tests.el |