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