Mercurial > hg > xemacs-beta
annotate tests/automated/lisp-tests.el @ 5353:38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
lisp/ChangeLog addition:
2011-02-07 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el:
* bytecomp.el (byte-compile-initial-macro-environment):
Shadow `block', `return-from' here, we implement them differently
when byte-compiling.
* bytecomp.el (byte-compile-active-blocks): New.
* bytecomp.el (byte-compile-block-1): New.
* bytecomp.el (byte-compile-return-from-1): New.
* bytecomp.el (return-from-1): New.
* bytecomp.el (block-1): New.
These are two aliases that exist to have their own associated
byte-compile functions, which functions implement `block' and
`return-from'.
* cl-extra.el (cl-macroexpand-all):
Fix a bug here when macros in the environment have been compiled.
* cl-macs.el (block):
* cl-macs.el (return):
* cl-macs.el (return-from):
Be more careful about lexical scope in these macros.
* cl.el:
* cl.el ('cl-block-wrapper): Removed.
* cl.el ('cl-block-throw): Removed.
These aren't needed in code generated by this XEmacs. They
shouldn't be needed in code generated by XEmacs 21.4, but if it
turns out the packages do need them, we can put them back.
2011-01-30 Mike Sperber <mike@xemacs.org>
* font-lock.el (font-lock-fontify-pending-extents): Don't fail if
`font-lock-mode' is unset, which can happen in the middle of
`revert-buffer'.
2011-01-23 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (delete):
* cl-macs.el (delq):
* cl-macs.el (remove):
* cl-macs.el (remq):
Don't use the compiler macro if these functions were given the
wrong number of arguments, as happens in lisp-tests.el.
* cl-seq.el (remove, remq): Removed.
I added these to subr.el, and forgot to remove them from here.
2011-01-22 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-setq, byte-compile-set):
Remove kludge allowing keywords' values to be set, all the code
that does that is gone.
* cl-compat.el (elt-satisfies-test-p):
* faces.el (set-face-parent):
* faces.el (face-doc-string):
* gtk-font-menu.el:
* gtk-font-menu.el (gtk-reset-device-font-menus):
* msw-font-menu.el:
* msw-font-menu.el (mswindows-reset-device-font-menus):
* package-get.el (package-get-installedp):
* select.el (select-convert-from-image-data):
* sound.el:
* sound.el (load-sound-file):
* x-font-menu.el (x-reset-device-font-menus-core):
Don't quote keywords, they're self-quoting, and the
win from backward-compatibility is sufficiently small now that the
style problem overrides it.
2011-01-22 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (block, return-from): Require that NAME be a symbol
in these macros, as always documented in the #'block docstring and
as required by Common Lisp.
* descr-text.el (unidata-initialize-unihan-database):
Correct the use of non-symbols in #'block and #'return-from in
this function.
2011-01-15 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (concatenate): Accept more complicated TYPEs in this
function, handing the sequences over to #'coerce if we don't
understand them here.
* cl-macs.el (inline): Don't proclaim #'concatenate as inline, its
compiler macro is more useful than doing that.
2011-01-11 Aidan Kehoe <kehoea@parhasard.net>
* subr.el (delete, delq, remove, remq): Move #'remove, #'remq
here, they don't belong in cl-seq.el; move #'delete, #'delq here
from fns.c, implement them in terms of #'delete*, allowing support
for sequences generally.
* update-elc.el (do-autoload-commands): Use #'delete*, not #'delq
here, now the latter's no longer dumped.
* cl-macs.el (delete, delq): Add compiler macros transforming
#'delete and #'delq to #'delete* calls.
2011-01-10 Aidan Kehoe <kehoea@parhasard.net>
* dialog.el (make-dialog-box): Correct a misplaced parenthesis
here, thank you Mats Lidell in 87zkr9gqrh.fsf@mail.contactor.se !
2011-01-02 Aidan Kehoe <kehoea@parhasard.net>
* dialog.el (make-dialog-box):
* list-mode.el (display-completion-list):
These functions used to use cl-parsing-keywords; change them to
use defun* instead, fixing the build. (Not sure what led to me
not including this change in d1b17a33450b!)
2011-01-02 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (define-star-compiler-macros):
Make sure the form has ITEM and LIST specified before attempting
to change to calls with explicit tests; necessary for some tests
in lisp-tests.el to compile correctly.
(stable-union, stable-intersection): Add compiler macros for these
functions, in the same way we do for most of the other functions
in cl-seq.el.
2011-01-01 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (dolist, dotimes, do-symbols, macrolet)
(symbol-macrolet):
Define these macros with defmacro* instead of parsing the argument
list by hand, for the sake of style and readability; use backquote
where appropriate, instead of calling #'list and and friends, for
the same reason.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* x-misc.el (device-x-display):
Provide this function, documented in the Lispref for years, but
not existing previously. Thank you Julian Bradfield, thank you
Jeff Mincy.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* cl-seq.el:
Move the heavy lifting from this file to C. Dump the
cl-parsing-keywords macro, but don't use defun* for the functions
we define that do take keywords, dynamic scope lossage makes that
not practical.
* subr.el (sort, fillarray): Move these aliases here.
(map-plist): #'nsublis is now built-in, but at this point #'eql
isn't necessarily available as a test; use #'eq.
* obsolete.el (cl-delete-duplicates): Make this available for old
compiler macros and old code.
(memql): Document that this is equivalent to #'member*, and worse.
* cl.el (adjoin, subst): Removed. These are in C.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* simple.el (assoc-ignore-case): Remove a duplicate definition of
this function (it's already in subr.el).
* iso8859-1.el (char-width):
On non-Mule, make this function equivalent to that produced by
(constantly 1), but preserve its docstring.
* subr.el (subst-char-in-string): Define this in terms of
#'substitute, #'nsubstitute.
(string-width): Define this using #'reduce and #'char-width.
(char-width): Give this a simpler definition, it makes far more
sense to check for mule at load time and redefine, as we do in
iso8859-1.el.
(store-substring): Implement this in terms of #'replace, now
#'replace is cheap.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* update-elc.el (lisp-files-needed-for-byte-compilation)
(lisp-files-needing-early-byte-compilation):
cl-macs belongs in the former, not the latter, it is as
fundamental as bytecomp.el.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* cl.el:
Provde the Common Lisp program-error, type-error as error
symbols. This doesn't nearly go far enough for anyone using the
Common Lisp errors.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (delete-duplicates):
If the form has an incorrect number of arguments, don't attempt a
compiler macroexpansion.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (cl-safe-expr-p):
Forms that start with the symbol lambda are also safe.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (= < > <= >=):
For these functions' compiler macros, the optimisation is safe
even if the first and the last arguments have side effects, since
they're only used the once.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (inline-side-effect-free-compiler-macros):
Unroll a loop here at macro-expansion time, so these compiler
macros are compiled. Use #'eql instead of #'eq in a couple of
places for better style.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (notany, notevery): Avoid some dynamic scope
stupidity with local variable names in these functions, when they
weren't prefixed with cl-; go into some more detail in the doc
strings.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* byte-optimize.el (side-effect-free-fns): #'remove, #'remq are
free of side-effects.
(side-effect-and-error-free-fns):
Drop dot, dot-marker from the list.
2010-11-17 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (coerce):
In the argument list, name the first argument OBJECT, not X; the
former name was always used in the doc string and is clearer.
Handle vector type specifications which include the length of the
target sequence, error if there's a mismatch.
* cl-macs.el (cl-make-type-test): Handle type specifications
starting with the symbol 'eql.
2010-11-14 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (eql): Don't remove the byte-compile property of this
symbol. That was necessary to override a bug in bytecomp.el where
#'eql was confused with #'eq, which bug we no longer have.
If neither expression is constant, don't attempt to handle the
expression in this compiler macro, leave it to byte-compile-eql,
which produces better code anyway.
* bytecomp.el (eq): #'eql is not the function associated with the
byte-eq byte code.
(byte-compile-eql): Add an explicit compile method for this
function, for cases where the cl-macs compiler macro hasn't
reduced it to #'eq or #'equal.
2010-10-25 Aidan Kehoe <kehoea@parhasard.net>
Add compiler macros and compilation sanity-checking for various
functions that take keywords.
* byte-optimize.el (side-effect-free-fns): #'symbol-value is
side-effect free and not error free.
* bytecomp.el (byte-compile-normal-call): Check keyword argument
lists for sanity; store information about the positions where
keyword arguments start using the new byte-compile-keyword-start
property.
* cl-macs.el (cl-const-expr-val): Take a new optional argument,
cl-not-constant, defaulting to nil, in this function; return it if
the expression is not constant.
(cl-non-fixnum-number-p): Make this into a separate function, we
want to pass it to #'every.
(eql): Use it.
(define-star-compiler-macros): Use the same code to generate the
member*, assoc* and rassoc* compiler macros; special-case some
code in #'add-to-list in subr.el.
(remove, remq): Add compiler macros for these two functions, in
preparation for #'remove being in C.
(define-foo-if-compiler-macros): Transform (remove-if-not ...) calls to
(remove ... :if-not) at compile time, which will be a real win
once the latter is in C.
(define-substitute-if-compiler-macros)
(define-subst-if-compiler-macros): Similarly for these functions.
(delete-duplicates): Change this compiler macro to use
#'plists-equal; if we don't have information about the type of
SEQUENCE at compile time, don't bother attempting to inline the
call, the function will be in C soon enough.
(equalp): Remove an old commented-out compiler macro for this, if
we want to see it it's in version control.
(subst-char-in-string): Transform this to a call to nsubstitute or
nsubstitute, if that is appropriate.
* cl.el (ldiff): Don't call setf here, this makes for a load-time
dependency problem in cl-macs.el
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* term/vt100.el:
Refer to XEmacs, not GNU Emacs, in permissions.
* term/bg-mouse.el:
* term/sup-mouse.el:
Put copyright notice in canonical "Copyright DATE AUTHOR" form.
Refer to XEmacs, not GNU Emacs, in permissions.
* site-load.el:
Add permission boilerplate.
* mule/canna-leim.el:
* alist.el:
Refer to XEmacs, not APEL/this program, in permissions.
* mule/canna-leim.el:
Remove my copyright, I've assigned it to the FSF.
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* gtk.el:
* gtk-widget-accessors.el:
* gtk-package.el:
* gtk-marshal.el:
* gtk-compose.el:
* gnome.el:
Add copyright notice based on internal evidence.
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* easymenu.el: Add reference to COPYING to permission notice.
* gutter.el:
* gutter-items.el:
* menubar-items.el:
Fix typo "Xmacs" in permissions notice.
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* auto-save.el:
* font.el:
* fontconfig.el:
* mule/kinsoku.el:
Add "part of XEmacs" text to permission notice.
2010-10-14 Aidan Kehoe <kehoea@parhasard.net>
* byte-optimize.el (side-effect-free-fns):
* cl-macs.el (remf, getf):
* cl-extra.el (tailp, cl-set-getf, cl-do-remf):
* cl.el (ldiff, endp):
Tighten up Common Lisp compatibility for #'ldiff, #'endp, #'tailp;
add circularity checking for the first two.
#'cl-set-getf and #'cl-do-remf were Lisp implementations of
#'plist-put and #'plist-remprop; change the names to aliases,
changes the macros that use them to using #'plist-put and
#'plist-remprop directly.
2010-10-12 Aidan Kehoe <kehoea@parhasard.net>
* abbrev.el (fundamental-mode-abbrev-table, global-abbrev-table):
Create both these abbrev tables using the usual
#'define-abbrev-table calls, rather than attempting to
special-case them.
* cl-extra.el: Force cl-macs to be loaded here, if cl-extra.el is
being loaded interpreted. Previously other, later files would
redundantly call (load "cl-macs") when interpreted, it's more
reasonable to do it here, once.
* cmdloop.el (read-quoted-char-radix): Use defcustom here, we
don't have any dump-order dependencies that would prevent that.
* custom.el (eval-when-compile): Don't load cl-macs when
interpreted or when byte-compiling, rely on cl-extra.el in the
former case and the appropriate entry in bytecomp-load-hook in the
latter. Get rid of custom-declare-variable-list, we have no
dump-time dependencies that would require it.
* faces.el (eval-when-compile): Don't load cl-macs when
interpreted or when byte-compiling.
* packages.el: Remove some inaccurate comments.
* post-gc.el (cleanup-simple-finalizers): Use #'delete-if-not
here, now the order of preloaded-file-list has been changed to
make it available.
* subr.el (custom-declare-variable-list): Remove. No need for it.
Also remove a stub define-abbrev-table from this file, given the
current order of preloaded-file-list there's no need for it.
2010-10-10 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-constp) Forms quoted with FUNCTION are
also constant.
(byte-compile-initial-macro-environment): In #'the, if FORM is
constant and does not match TYPE, warn at byte-compile time.
2010-10-10 Aidan Kehoe <kehoea@parhasard.net>
* backquote.el (bq-vector-contents, bq-list*): Remove; the former
is equivalent to (append VECTOR nil), the latter to (list* ...).
(bq-process-2): Use (append VECTOR nil) instead of using
#'bq-vector-contents to convert to a list.
(bq-process-1): Now we use list* instead of bq-list
* subr.el (list*): Moved from cl.el, since it is now required to
be available the first time a backquoted form is encountered.
* cl.el (list*): Move to subr.el.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* test-harness.el (Check-Message):
Add an omitted comma here, thank you the buildbot.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* hash-table.el (hash-table-key-list, hash-table-value-list)
(hash-table-key-value-alist, hash-table-key-value-plist):
Remove some useless #'nreverse calls in these files; our hash
tables have no order, it's not helpful to pretend they do.
* behavior.el (read-behavior):
Do the same in this file, in some code evidently copied from
hash-table.el.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* info.el (Info-insert-dir):
* format.el (format-deannotate-region):
* files.el (cd, save-buffers-kill-emacs):
Use #'some, #'every and related functions for applying boolean
operations to lists, instead of rolling our own ones that cons and
don't short-circuit.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-initial-macro-environment):
* cl-macs.el (the):
Rephrase the docstring, make its implementation when compiling
files a little nicer.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* descr-text.el (unidata-initialize-unicodedata-database)
(unidata-initialize-unihan-database, describe-char-unicode-data)
(describe-char-unicode-data):
Wrap calls to the database functions with (with-fboundp ...),
avoiding byte compile warnings on builds without support for the
database functions.
(describe-char): (reduce #'max ...), not (apply #'max ...), no
need to cons needlessly.
(describe-char): Remove a redundant lambda wrapping
#'extent-properties.
(describe-char-unicode-data): Call #'nsubst when replacing "" with
nil in the result of #'split-string, instead of consing inside
mapcar.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* x-faces.el (x-available-font-sizes):
* specifier.el (let-specifier):
* package-ui.el (pui-add-required-packages):
* msw-faces.el (mswindows-available-font-sizes):
* modeline.el (modeline-minor-mode-menu):
* minibuf.el (minibuf-directory-files):
Replace the O2N (delq nil (mapcar (lambda (W) (and X Y)) Z)) with
the ON (mapcan (lambda (W) (and X (list Y))) Z) in these files.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (= < > <= >=):
When these functions are handed more than two arguments, and those
arguments have no side effects, transform to a series of two
argument calls, avoiding funcall in the byte-compiled code.
* mule/mule-cmds.el (finish-set-language-environment):
Take advantage of this change in a function called 256 times at
startup.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-function-form, byte-compile-quote)
(byte-compile-quote-form):
Warn at compile time, and error at runtime, if a (quote ...) or a
(function ...) form attempts to quote more than one object.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* byte-optimize.el (byte-optimize-apply): Transform (apply 'nconc
(mapcar ...)) to (mapcan ...); warn about use of the first idiom.
* update-elc.el (do-autoload-commands):
* packages.el (packages-find-package-library-path):
* frame.el (frame-list):
* extents.el (extent-descendants):
* etags.el (buffer-tag-table-files):
* dumped-lisp.el (preloaded-file-list):
* device.el (device-list):
* bytecomp-runtime.el (proclaim-inline, proclaim-notinline)
Use #'mapcan, not (apply #'nconc (mapcar ...) in all these files.
* bytecomp-runtime.el (eval-when-compile, eval-and-compile):
In passing, mention that these macros also evaluate the body when
interpreted.
tests/ChangeLog addition:
2011-02-07 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el:
Test lexical scope for `block', `return-from'; add a
Known-Bug-Expect-Failure for a contorted example that fails when
byte-compiled.
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Mon, 07 Feb 2011 12:01:24 +0000 |
parents | fd441b85d760 |
children | 70b15ac66ee5 0af042a0c116 |
rev | line source |
---|---|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1 ;; Copyright (C) 1998 Free Software Foundation, Inc. -*- coding: iso-8859-1 -*- |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2 ;; Copyright (C) 2010 Ben Wing. |
428 | 3 |
4 ;; Author: Martin Buchholz <martin@xemacs.org> | |
5 ;; Maintainer: Martin Buchholz <martin@xemacs.org> | |
6 ;; Created: 1998 | |
7 ;; Keywords: tests | |
8 | |
9 ;; This file is part of XEmacs. | |
10 | |
11 ;; XEmacs is free software; you can redistribute it and/or modify it | |
12 ;; under the terms of the GNU General Public License as published by | |
13 ;; the Free Software Foundation; either version 2, or (at your option) | |
14 ;; any later version. | |
15 | |
16 ;; XEmacs is distributed in the hope that it will be useful, but | |
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
19 ;; General Public License for more details. | |
20 | |
21 ;; You should have received a copy of the GNU General Public License | |
22 ;; along with XEmacs; see the file COPYING. If not, write to the Free | |
23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA | |
24 ;; 02111-1307, USA. | |
25 | |
26 ;;; Synched up with: Not in FSF. | |
27 | |
28 ;;; Commentary: | |
29 | |
30 ;;; Test basic Lisp engine functionality | |
31 ;;; See test-harness.el for instructions on how to run these tests. | |
32 | |
33 (eval-when-compile | |
34 (condition-case nil | |
35 (require 'test-harness) | |
36 (file-error | |
37 (push "." load-path) | |
38 (when (and (boundp 'load-file-name) (stringp load-file-name)) | |
39 (push (file-name-directory load-file-name) load-path)) | |
40 (require 'test-harness)))) | |
41 | |
42 (Check-Error wrong-number-of-arguments (setq setq-test-foo)) | |
43 (Check-Error wrong-number-of-arguments (setq setq-test-foo 1 setq-test-bar)) | |
44 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo)) | |
45 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo 1 setq-test-bar)) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
46 (Assert (eq (setq) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
47 (Assert (eq (setq-default) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
48 (Assert (eq (setq setq-test-foo 42) 42)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
49 (Assert (eq (setq-default setq-test-foo 42) 42)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
50 (Assert (eq (setq setq-test-foo 42 setq-test-bar 99) 99)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
51 (Assert (eq (setq-default setq-test-foo 42 setq-test-bar 99) 99)) |
428 | 52 |
53 (macrolet ((test-setq (expected-result &rest body) | |
54 `(progn | |
55 (defun test-setq-fun () ,@body) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
56 (Assert (eq ,expected-result (test-setq-fun))) |
428 | 57 (byte-compile 'test-setq-fun) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
58 (Assert (eq ,expected-result (test-setq-fun)))))) |
428 | 59 (test-setq nil (setq)) |
60 (test-setq nil (setq-default)) | |
61 (test-setq 42 (setq test-setq-var 42)) | |
62 (test-setq 42 (setq-default test-setq-var 42)) | |
63 (test-setq 42 (setq test-setq-bar 99 test-setq-var 42)) | |
64 (test-setq 42 (setq-default test-setq-bar 99 test-setq-var 42)) | |
65 ) | |
66 | |
67 (let ((my-vector [1 2 3 4]) | |
68 (my-bit-vector (bit-vector 1 0 1 0)) | |
69 (my-string "1234") | |
70 (my-list '(1 2 3 4))) | |
71 | |
72 ;;(Assert (fooooo)) ;; Generate Other failure | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
73 ;;(Assert (eq 1 2)) ;; Generate Assertion failure |
428 | 74 |
75 (dolist (sequence (list my-vector my-bit-vector my-string my-list)) | |
76 (Assert (sequencep sequence)) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
77 (Assert (eq 4 (length sequence)))) |
428 | 78 |
79 (dolist (array (list my-vector my-bit-vector my-string)) | |
80 (Assert (arrayp array))) | |
81 | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
82 (Assert (eq (elt my-vector 0) 1)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
83 (Assert (eq (elt my-bit-vector 0) 1)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
84 (Assert (eq (elt my-string 0) ?1)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
85 (Assert (eq (elt my-list 0) 1)) |
428 | 86 |
87 (fillarray my-vector 5) | |
88 (fillarray my-bit-vector 1) | |
89 (fillarray my-string ?5) | |
90 | |
91 (dolist (array (list my-vector my-bit-vector)) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
92 (Assert (eq 4 (length array)))) |
428 | 93 |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
94 (Assert (eq (elt my-vector 0) 5)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
95 (Assert (eq (elt my-bit-vector 0) 1)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
96 (Assert (eq (elt my-string 0) ?5)) |
428 | 97 |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
98 (Assert (eq (elt my-vector 3) 5)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
99 (Assert (eq (elt my-bit-vector 3) 1)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
100 (Assert (eq (elt my-string 3) ?5)) |
428 | 101 |
102 (fillarray my-bit-vector 0) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
103 (Assert (eq 4 (length my-bit-vector))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
104 (Assert (eq (elt my-bit-vector 2) 0)) |
428 | 105 ) |
106 | |
107 (defun make-circular-list (length) | |
108 "Create evil emacs-crashing circular list of length LENGTH" | |
109 (let ((circular-list | |
110 (make-list | |
111 length | |
112 'you-are-trapped-in-a-twisty-maze-of-cons-cells-all-alike))) | |
113 (setcdr (last circular-list) circular-list) | |
114 circular-list)) | |
115 | |
116 ;;----------------------------------------------------- | |
117 ;; Test `nconc' | |
118 ;;----------------------------------------------------- | |
119 (defun make-list-012 () (list 0 1 2)) | |
120 | |
121 (Check-Error wrong-type-argument (nconc 'foo nil)) | |
122 | |
123 (dolist (length '(1 2 3 4 1000 2000)) | |
124 (Check-Error circular-list (nconc (make-circular-list length) 'foo)) | |
125 (Check-Error circular-list (nconc '(1 . 2) (make-circular-list length) 'foo)) | |
126 (Check-Error circular-list (nconc '(1 . 2) '(3 . 4) (make-circular-list length) 'foo))) | |
127 | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
128 (Assert (eq (nconc) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
129 (Assert (eq (nconc nil) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
130 (Assert (eq (nconc nil nil) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
131 (Assert (eq (nconc nil nil nil) nil)) |
428 | 132 |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
133 (let ((x (make-list-012))) (Assert (eq (nconc nil x) x))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
134 (let ((x (make-list-012))) (Assert (eq (nconc x nil) x))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
135 (let ((x (make-list-012))) (Assert (eq (nconc nil x nil) x))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
136 (let ((x (make-list-012))) (Assert (eq (nconc x) x))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
137 (let ((x (make-list-012))) (Assert (eq (nconc x (make-circular-list 3)) x))) |
428 | 138 |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
139 (Assert (equal (nconc '(1 . 2) '(3 . 4) '(5 . 6)) '(1 3 5 . 6))) |
428 | 140 |
141 (let ((y (nconc (make-list-012) nil (list 3 4 5) nil))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
142 (Assert (eq (length y) 6)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
143 (Assert (eq (nth 3 y) 3))) |
428 | 144 |
145 ;;----------------------------------------------------- | |
146 ;; Test `last' | |
147 ;;----------------------------------------------------- | |
148 (Check-Error wrong-type-argument (last 'foo)) | |
149 (Check-Error wrong-number-of-arguments (last)) | |
150 (Check-Error wrong-number-of-arguments (last '(1 2) 1 1)) | |
151 (Check-Error circular-list (last (make-circular-list 1))) | |
152 (Check-Error circular-list (last (make-circular-list 2000))) | |
153 (let ((x (list 0 1 2 3))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
154 (Assert (eq (last nil) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
155 (Assert (eq (last x 0) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
156 (Assert (eq (last x ) (cdddr x))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
157 (Assert (eq (last x 1) (cdddr x))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
158 (Assert (eq (last x 2) (cddr x))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
159 (Assert (eq (last x 3) (cdr x))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
160 (Assert (eq (last x 4) x)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
161 (Assert (eq (last x 9) x)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
162 (Assert (eq (last '(1 . 2) 0) 2)) |
428 | 163 ) |
164 | |
165 ;;----------------------------------------------------- | |
166 ;; Test `butlast' and `nbutlast' | |
167 ;;----------------------------------------------------- | |
168 (Check-Error wrong-type-argument (butlast 'foo)) | |
169 (Check-Error wrong-type-argument (nbutlast 'foo)) | |
170 (Check-Error wrong-number-of-arguments (butlast)) | |
171 (Check-Error wrong-number-of-arguments (nbutlast)) | |
172 (Check-Error wrong-number-of-arguments (butlast '(1 2) 1 1)) | |
173 (Check-Error wrong-number-of-arguments (nbutlast '(1 2) 1 1)) | |
174 (Check-Error circular-list (butlast (make-circular-list 1))) | |
175 (Check-Error circular-list (nbutlast (make-circular-list 1))) | |
176 (Check-Error circular-list (butlast (make-circular-list 2000))) | |
177 (Check-Error circular-list (nbutlast (make-circular-list 2000))) | |
178 | |
179 (let* ((x (list 0 1 2 3)) | |
180 (y (butlast x)) | |
181 (z (nbutlast x))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
182 (Assert (eq z x)) |
428 | 183 (Assert (not (eq y x))) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
184 (Assert (equal y '(0 1 2))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
185 (Assert (equal z y))) |
428 | 186 |
187 (let* ((x (list 0 1 2 3 4)) | |
188 (y (butlast x 2)) | |
189 (z (nbutlast x 2))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
190 (Assert (eq z x)) |
428 | 191 (Assert (not (eq y x))) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
192 (Assert (equal y '(0 1 2))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
193 (Assert (equal z y))) |
428 | 194 |
195 (let* ((x (list 0 1 2 3)) | |
196 (y (butlast x 0)) | |
197 (z (nbutlast x 0))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
198 (Assert (eq z x)) |
428 | 199 (Assert (not (eq y x))) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
200 (Assert (equal y '(0 1 2 3))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
201 (Assert (equal z y))) |
428 | 202 |
5285
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
203 (let* ((x (list* 0 1 2 3 4 5 6.0 ?7 ?8 (vector 'a 'b 'c))) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
204 (y (butlast x 0)) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
205 (z (nbutlast x 0))) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
206 (Assert (eq z x)) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
207 (Assert (not (eq y x))) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
208 (Assert (equal y '(0 1 2 3 4 5 6.0 ?7 ?8))) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
209 (Assert (equal z y))) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
210 |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
211 (Assert (eq (butlast '(x)) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
212 (Assert (eq (nbutlast '(x)) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
213 (Assert (eq (butlast '()) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
214 (Assert (eq (nbutlast '()) nil)) |
428 | 215 |
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
216 (when (featurep 'bignum) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
217 (let* ((x (list* 0 1 2 3 4 5 6.0 ?7 ?8 (vector 'a 'b 'c))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
218 (y (butlast x (* 2 most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
219 (z (nbutlast x (* 3 most-positive-fixnum)))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
220 (Assert (eq nil y) "checking butlast with a large bignum gives nil") |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
221 (Assert (eq nil z) "checking nbutlast with a large bignum gives nil") |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
222 (Check-Error wrong-type-argument |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
223 (nbutlast x (1- most-negative-fixnum)) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
224 "checking nbutlast with a negative bignum errors"))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
225 |
428 | 226 ;;----------------------------------------------------- |
227 ;; Test `copy-list' | |
228 ;;----------------------------------------------------- | |
229 (Check-Error wrong-type-argument (copy-list 'foo)) | |
230 (Check-Error wrong-number-of-arguments (copy-list)) | |
231 (Check-Error wrong-number-of-arguments (copy-list '(1 2) 1)) | |
232 (Check-Error circular-list (copy-list (make-circular-list 1))) | |
233 (Check-Error circular-list (copy-list (make-circular-list 2000))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
234 (Assert (eq '() (copy-list '()))) |
428 | 235 (dolist (x '((1) (1 2) (1 2 3) (1 2 . 3))) |
236 (let ((y (copy-list x))) | |
237 (Assert (and (equal x y) (not (eq x y)))))) | |
238 | |
239 ;;----------------------------------------------------- | |
5285
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
240 ;; Test `ldiff' |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
241 ;;----------------------------------------------------- |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
242 (Check-Error wrong-type-argument (ldiff 'foo pi)) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
243 (Check-Error wrong-number-of-arguments (ldiff)) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
244 (Check-Error wrong-number-of-arguments (ldiff '(1 2))) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
245 (Check-Error circular-list (ldiff (make-circular-list 1) nil)) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
246 (Check-Error circular-list (ldiff (make-circular-list 2000) nil)) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
247 (Assert (eq '() (ldiff '() pi))) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
248 (dolist (x '((1) (1 2) (1 2 3) (1 2 . 3))) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
249 (let ((y (ldiff x nil))) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
250 (Assert (and (equal x y) (not (eq x y)))))) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
251 |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
252 (let* ((vector (vector 'foo)) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
253 (dotted `(1 2 3 ,pi 40 50 . ,vector)) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
254 (dotted-pi `(1 2 3 . ,pi)) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
255 without-vector without-pi) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
256 (Assert (equal dotted (ldiff dotted nil)) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
257 "checking ldiff handles dotted lists properly") |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
258 (Assert (equal (butlast dotted 0) (ldiff dotted vector)) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
259 "checking ldiff discards dotted elements correctly") |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
260 (Assert (equal (butlast dotted-pi 0) (ldiff dotted-pi (* 4 (atan 1)))) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
261 "checking ldiff handles float equivalence correctly")) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
262 |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
263 ;;----------------------------------------------------- |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
264 ;; Test `tailp' |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
265 ;;----------------------------------------------------- |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
266 (Check-Error wrong-type-argument (tailp pi 'foo)) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
267 (Check-Error wrong-number-of-arguments (tailp)) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
268 (Check-Error wrong-number-of-arguments (tailp '(1 2))) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
269 (Check-Error circular-list (tailp nil (make-circular-list 1))) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
270 (Check-Error circular-list (tailp nil (make-circular-list 2000))) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
271 (Assert (null (tailp pi '())) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
272 "checking pi is not a tail of the list nil") |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
273 (Assert (tailp 3 '(1 2 . 3)) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
274 "checking #'tailp works with a dotted integer.") |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
275 (Assert (tailp pi `(1 2 . ,(* 4 (atan 1)))) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
276 "checking tailp works with non-eq dotted floats.") |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
277 (let ((list (make-list 2048 nil))) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
278 (Assert (tailp (nthcdr 2000 list) (nconc list list)) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
279 "checking #'tailp succeeds with circular LIST containing SUBLIST")) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
280 |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
281 ;;----------------------------------------------------- |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
282 ;; Test `endp' |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
283 ;;----------------------------------------------------- |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
284 (Check-Error wrong-type-argument (endp 'foo)) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
285 (Check-Error wrong-number-of-arguments (endp)) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
286 (Check-Error wrong-number-of-arguments (endp '(1 2) 'foo)) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
287 (Assert (endp nil) "checking nil is recognized as the end of a list") |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
288 (Assert (not (endp (list 200 200 4 0 9))) |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
289 "checking a cons is not recognised as the end of a list") |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
290 |
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
291 ;;----------------------------------------------------- |
428 | 292 ;; Arithmetic operations |
293 ;;----------------------------------------------------- | |
294 | |
295 ;; Test `+' | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
296 (Assert (eq (+ 1 1) 2)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
297 (Assert (= (+ 1.0 1.0) 2.0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
298 (Assert (= (+ 1.0 3.0 0.0) 4.0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
299 (Assert (= (+ 1 1.0) 2.0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
300 (Assert (= (+ 1.0 1) 2.0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
301 (Assert (= (+ 1.0 1 1) 3.0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
302 (Assert (= (+ 1 1 1.0) 3.0)) |
1983 | 303 (if (featurep 'bignum) |
304 (progn | |
305 (Assert (bignump (1+ most-positive-fixnum))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
306 (Assert (eq most-positive-fixnum (1- (1+ most-positive-fixnum)))) |
1983 | 307 (Assert (bignump (+ most-positive-fixnum 1))) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
308 (Assert (eq most-positive-fixnum (- (+ most-positive-fixnum 1) 1))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
309 (Assert (= (1+ most-positive-fixnum) (- most-negative-fixnum))) |
1983 | 310 (Assert (zerop (+ (* 3 most-negative-fixnum) (* 3 most-positive-fixnum) |
311 3)))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
312 (Assert (eq (1+ most-positive-fixnum) most-negative-fixnum)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
313 (Assert (eq (+ most-positive-fixnum 1) most-negative-fixnum))) |
1983 | 314 |
315 (when (featurep 'ratio) | |
316 (let ((threefourths (read "3/4")) | |
317 (threehalfs (read "3/2")) | |
318 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum))) | |
319 (bigneg (div (+ most-positive-fixnum 2) most-negative-fixnum)) | |
320 (negone (div (1+ most-positive-fixnum) most-negative-fixnum))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
321 (Assert (= negone -1)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
322 (Assert (= threehalfs (+ threefourths threefourths))) |
1983 | 323 (Assert (zerop (+ bigpos bigneg))))) |
428 | 324 |
325 ;; Test `-' | |
326 (Check-Error wrong-number-of-arguments (-)) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
327 (Assert (eq (- 0) 0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
328 (Assert (eq (- 1) -1)) |
428 | 329 (dolist (one `(1 1.0 ?\1 ,(Int-to-Marker 1))) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
330 (Assert (= (+ 1 one) 2)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
331 (Assert (= (+ one) 1)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
332 (Assert (= (+ one) one)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
333 (Assert (= (- one) -1)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
334 (Assert (= (- one one) 0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
335 (Assert (= (- one one one) -1)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
336 (Assert (= (- 0 one) -1)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
337 (Assert (= (- 0 one one) -2)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
338 (Assert (= (+ one 1) 2)) |
428 | 339 (dolist (zero '(0 0.0 ?\0)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
340 (Assert (= (+ 1 zero) 1) zero) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
341 (Assert (= (+ zero 1) 1) zero) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
342 (Assert (= (- zero) zero) zero) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
343 (Assert (= (- zero) 0) zero) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
344 (Assert (= (- zero zero) 0) zero) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
345 (Assert (= (- zero one one) -2) zero))) |
428 | 346 |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
347 (Assert (= (- 1.5 1) .5)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
348 (Assert (= (- 1 1.5) (- .5))) |
428 | 349 |
1983 | 350 (if (featurep 'bignum) |
351 (progn | |
352 (Assert (bignump (1- most-negative-fixnum))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
353 (Assert (eq most-negative-fixnum (1+ (1- most-negative-fixnum)))) |
1983 | 354 (Assert (bignump (- most-negative-fixnum 1))) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
355 (Assert (eq most-negative-fixnum (+ (- most-negative-fixnum 1) 1))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
356 (Assert (= (1- most-negative-fixnum) (- 0 most-positive-fixnum 2))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
357 (Assert (eq (- (- most-positive-fixnum most-negative-fixnum) |
1983 | 358 (* 2 most-positive-fixnum)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
359 1))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
360 (Assert (eq (1- most-negative-fixnum) most-positive-fixnum)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
361 (Assert (eq (- most-negative-fixnum 1) most-positive-fixnum))) |
1983 | 362 |
363 (when (featurep 'ratio) | |
364 (let ((threefourths (read "3/4")) | |
365 (threehalfs (read "3/2")) | |
366 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum))) | |
367 (bigneg (div most-positive-fixnum most-negative-fixnum)) | |
368 (negone (div (1+ most-positive-fixnum) most-negative-fixnum))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
369 (Assert (= (- negone) 1)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
370 (Assert (= threefourths (- threehalfs threefourths))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
371 (Assert (= (- bigpos bigneg) 2)))) |
428 | 372 |
373 ;; Test `/' | |
374 | |
375 ;; Test division by zero errors | |
376 (dolist (zero '(0 0.0 ?\0)) | |
377 (Check-Error arith-error (/ zero)) | |
378 (dolist (n1 `(42 42.0 ?\042 ,(Int-to-Marker 42))) | |
379 (Check-Error arith-error (/ n1 zero)) | |
380 (dolist (n2 `(3 3.0 ?\03 ,(Int-to-Marker 3))) | |
381 (Check-Error arith-error (/ n1 n2 zero))))) | |
382 | |
383 ;; Other tests for `/' | |
384 (Check-Error wrong-number-of-arguments (/)) | |
385 (let (x) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
386 (Assert (= (/ (setq x 2)) 0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
387 (Assert (= (/ (setq x 2.0)) 0.5))) |
428 | 388 |
389 (dolist (six '(6 6.0 ?\06)) | |
390 (dolist (two '(2 2.0 ?\02)) | |
391 (dolist (three '(3 3.0 ?\03)) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
392 (Assert (= (/ six two) three) (list six two three))))) |
428 | 393 |
394 (dolist (three '(3 3.0 ?\03)) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
395 (Assert (= (/ three 2.0) 1.5) three)) |
428 | 396 (dolist (two '(2 2.0 ?\02)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
397 (Assert (= (/ 3.0 two) 1.5) two)) |
428 | 398 |
1983 | 399 (when (featurep 'bignum) |
400 (let* ((million 1000000) | |
401 (billion (* million 1000)) ;; American, not British, billion | |
402 (trillion (* billion 1000))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
403 (Assert (= (/ billion 1000) (/ trillion million) million 1000000.0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
404 (Assert (= (/ billion -1000) (/ trillion (- million)) (- million))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
405 (Assert (= (/ trillion 1000) billion 1000000000.0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
406 (Assert (= (/ trillion -1000) (- billion) -1000000000.0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
407 (Assert (= (/ trillion 10) (* 100 billion) 100000000000.0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
408 (Assert (= (/ (- trillion) 10) (* -100 billion) -100000000000.0)))) |
1983 | 409 |
410 (when (featurep 'ratio) | |
411 (let ((half (div 1 2)) | |
412 (fivefourths (div 5 4)) | |
413 (fivehalfs (div 5 2))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
414 (Assert (= half (read "3000000000/6000000000"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
415 (Assert (= (/ fivehalfs fivefourths) 2)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
416 (Assert (= (/ fivefourths fivehalfs) half)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
417 (Assert (= (- half) (read "-3000000000/6000000000"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
418 (Assert (= (/ fivehalfs (- fivefourths)) -2)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
419 (Assert (= (/ (- fivefourths) fivehalfs) (- half))))) |
1983 | 420 |
428 | 421 ;; Test `*' |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
422 (Assert (= 1 (*))) |
428 | 423 |
424 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
425 (Assert (= 1 (* one)) one)) |
428 | 426 |
427 (dolist (two '(2 2.0 ?\02)) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
428 (Assert (= 2 (* two)) two)) |
428 | 429 |
430 (dolist (six '(6 6.0 ?\06)) | |
431 (dolist (two '(2 2.0 ?\02)) | |
432 (dolist (three '(3 3.0 ?\03)) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
433 (Assert (= (* three two) six) (list three two six))))) |
428 | 434 |
435 (dolist (three '(3 3.0 ?\03)) | |
436 (dolist (two '(2 2.0 ?\02)) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
437 (Assert (= (* 1.5 two) three) (list two three)) |
428 | 438 (dolist (five '(5 5.0 ?\05)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
439 (Assert (= 30 (* five two three)) (list five two three))))) |
428 | 440 |
1983 | 441 (when (featurep 'bignum) |
442 (let ((64K 65536)) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
443 (Assert (= (* 64K 64K) (read "4294967296"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
444 (Assert (= (* (- 64K) 64K) (read "-4294967296"))) |
1983 | 445 (Assert (/= (* -1 most-negative-fixnum) most-negative-fixnum)))) |
446 | |
447 (when (featurep 'ratio) | |
448 (let ((half (div 1 2)) | |
449 (fivefourths (div 5 4)) | |
450 (twofifths (div 2 5))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
451 (Assert (= (* fivefourths twofifths) half)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
452 (Assert (= (* half twofifths) (read "3/15"))))) |
1983 | 453 |
428 | 454 ;; Test `+' |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
455 (Assert (= 0 (+))) |
428 | 456 |
457 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
458 (Assert (= 1 (+ one)) one)) |
428 | 459 |
460 (dolist (two '(2 2.0 ?\02)) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
461 (Assert (= 2 (+ two)) two)) |
428 | 462 |
463 (dolist (five '(5 5.0 ?\05)) | |
464 (dolist (two '(2 2.0 ?\02)) | |
465 (dolist (three '(3 3.0 ?\03)) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
466 (Assert (= (+ three two) five) (list three two five)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
467 (Assert (= 10 (+ five two three)) (list five two three))))) |
428 | 468 |
469 ;; Test `max', `min' | |
470 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
471 (Assert (= one (max one)) one) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
472 (Assert (= one (max one one)) one) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
473 (Assert (= one (max one one one)) one) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
474 (Assert (= one (min one)) one) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
475 (Assert (= one (min one one)) one) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
476 (Assert (= one (min one one one)) one) |
428 | 477 (dolist (two `(2 2.0 ?\02 ,(Int-to-Marker 2))) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
478 (Assert (= one (min one two)) (list one two)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
479 (Assert (= one (min one two two)) (list one two)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
480 (Assert (= one (min two two one)) (list one two)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
481 (Assert (= two (max one two)) (list one two)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
482 (Assert (= two (max one two two)) (list one two)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
483 (Assert (= two (max two two one)) (list one two)))) |
428 | 484 |
1983 | 485 (when (featurep 'bignum) |
486 (let ((big (1+ most-positive-fixnum)) | |
487 (small (1- most-negative-fixnum))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
488 (Assert (= big (max 1 1000000.0 most-positive-fixnum big))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
489 (Assert (= small (min -1 -1000000.0 most-negative-fixnum small))))) |
1983 | 490 |
491 (when (featurep 'ratio) | |
492 (let* ((big (1+ most-positive-fixnum)) | |
493 (small (1- most-negative-fixnum)) | |
494 (bigr (div (* 5 (1+ most-positive-fixnum)) 4)) | |
495 (smallr (- bigr))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
496 (Assert (= bigr (max 1 1000000.0 most-positive-fixnum big bigr))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
497 (Assert (= smallr (min -1 -1000000.0 most-negative-fixnum small smallr))))) |
1983 | 498 |
446 | 499 ;; The byte compiler has special handling for these constructs: |
500 (let ((three 3) (five 5)) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
501 (Assert (= (+ three five 1) 9)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
502 (Assert (= (+ 1 three five) 9)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
503 (Assert (= (+ three five -1) 7)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
504 (Assert (= (+ -1 three five) 7)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
505 (Assert (= (+ three 1) 4)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
506 (Assert (= (+ three -1) 2)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
507 (Assert (= (+ -1 three) 2)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
508 (Assert (= (+ -1 three) 2)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
509 (Assert (= (- three five 1) -3)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
510 (Assert (= (- 1 three five) -7)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
511 (Assert (= (- three five -1) -1)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
512 (Assert (= (- -1 three five) -9)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
513 (Assert (= (- three 1) 2)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
514 (Assert (= (- three 2 1) 0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
515 (Assert (= (- 2 three 1) -2)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
516 (Assert (= (- three -1) 4)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
517 (Assert (= (- three 0) 3)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
518 (Assert (= (- three 0 five) -2)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
519 (Assert (= (- 0 three 0 five) -8)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
520 (Assert (= (- 0 three five) -8)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
521 (Assert (= (* three 2) 6)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
522 (Assert (= (* three -1 five) -15)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
523 (Assert (= (* three 1 five) 15)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
524 (Assert (= (* three 0 five) 0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
525 (Assert (= (* three 2 five) 30)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
526 (Assert (= (/ three 1) 3)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
527 (Assert (= (/ three -1) -3)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
528 (Assert (= (/ (* five five) 2 2) 6)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
529 (Assert (= (/ 64 five 2) 6))) |
446 | 530 |
531 | |
428 | 532 ;;----------------------------------------------------- |
533 ;; Logical bit-twiddling operations | |
534 ;;----------------------------------------------------- | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
535 (Assert (= (logxor) 0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
536 (Assert (= (logior) 0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
537 (Assert (= (logand) -1)) |
428 | 538 |
539 (Check-Error wrong-type-argument (logxor 3.0)) | |
540 (Check-Error wrong-type-argument (logior 3.0)) | |
541 (Check-Error wrong-type-argument (logand 3.0)) | |
542 | |
543 (dolist (three '(3 ?\03)) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
544 (Assert (eq 3 (logand three)) three) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
545 (Assert (eq 3 (logxor three)) three) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
546 (Assert (eq 3 (logior three)) three) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
547 (Assert (eq 3 (logand three three)) three) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
548 (Assert (eq 0 (logxor three three)) three) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
549 (Assert (eq 3 (logior three three))) three) |
428 | 550 |
551 (dolist (one `(1 ?\01 ,(Int-to-Marker 1))) | |
552 (dolist (two '(2 ?\02)) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
553 (Assert (eq 0 (logand one two)) (list one two)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
554 (Assert (eq 3 (logior one two)) (list one two)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
555 (Assert (eq 3 (logxor one two)) (list one two))) |
428 | 556 (dolist (three '(3 ?\03)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
557 (Assert (eq 1 (logand one three)) (list one three)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
558 (Assert (eq 3 (logior one three)) (list one three)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
559 (Assert (eq 2 (logxor one three)) (list one three)))) |
428 | 560 |
561 ;;----------------------------------------------------- | |
562 ;; Test `%', mod | |
563 ;;----------------------------------------------------- | |
564 (Check-Error wrong-number-of-arguments (%)) | |
565 (Check-Error wrong-number-of-arguments (% 1)) | |
566 (Check-Error wrong-number-of-arguments (% 1 2 3)) | |
567 | |
568 (Check-Error wrong-number-of-arguments (mod)) | |
569 (Check-Error wrong-number-of-arguments (mod 1)) | |
570 (Check-Error wrong-number-of-arguments (mod 1 2 3)) | |
571 | |
572 (Check-Error wrong-type-argument (% 10.0 2)) | |
573 (Check-Error wrong-type-argument (% 10 2.0)) | |
574 | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
575 (flet ((test1 (x) (Assert (eql x (+ (% x 17) (* (/ x 17) 17))) x)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
576 (test2 (x) (Assert (eql (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17))) x)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
577 (test3 (x) (Assert (eql x (+ (% (- x) 17) (* (/ (- x) 17) 17))) x)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
578 (test4 (x) (Assert (eql (% x -17) (- (% (- x) 17))) x)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
579 (test5 (x) (Assert (eql (% x -17) (% (- x) 17))) x)) |
2056 | 580 (test1 most-negative-fixnum) |
581 (if (featurep 'bignum) | |
2075 | 582 (progn |
583 (test2 most-negative-fixnum) | |
584 (test4 most-negative-fixnum)) | |
585 (test3 most-negative-fixnum) | |
586 (test5 most-negative-fixnum)) | |
2056 | 587 (test1 most-positive-fixnum) |
588 (test2 most-positive-fixnum) | |
589 (test4 most-positive-fixnum) | |
590 (dotimes (j 30) | |
591 (let ((x (random))) | |
592 (if (eq x most-negative-fixnum) (setq x (1+ x))) | |
593 (if (eq x most-positive-fixnum) (setq x (1- x))) | |
594 (test1 x) | |
595 (test2 x) | |
596 (test4 x)))) | |
428 | 597 |
598 (macrolet | |
599 ((division-test (seven) | |
600 `(progn | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
601 (Assert (eq (% ,seven 2) 1)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
602 (Assert (eq (% ,seven -2) 1)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
603 (Assert (eq (% (- ,seven) 2) -1)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
604 (Assert (eq (% (- ,seven) -2) -1)) |
428 | 605 |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
606 (Assert (eq (% ,seven 4) 3)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
607 (Assert (eq (% ,seven -4) 3)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
608 (Assert (eq (% (- ,seven) 4) -3)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
609 (Assert (eq (% (- ,seven) -4) -3)) |
428 | 610 |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
611 (Assert (eq (% 35 ,seven) 0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
612 (Assert (eq (% -35 ,seven) 0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
613 (Assert (eq (% 35 (- ,seven)) 0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
614 (Assert (eq (% -35 (- ,seven)) 0)) |
428 | 615 |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
616 (Assert (eq (mod ,seven 2) 1)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
617 (Assert (eq (mod ,seven -2) -1)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
618 (Assert (eq (mod (- ,seven) 2) 1)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
619 (Assert (eq (mod (- ,seven) -2) -1)) |
428 | 620 |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
621 (Assert (eq (mod ,seven 4) 3)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
622 (Assert (eq (mod ,seven -4) -1)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
623 (Assert (eq (mod (- ,seven) 4) 1)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
624 (Assert (eq (mod (- ,seven) -4) -3)) |
428 | 625 |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
626 (Assert (eq (mod 35 ,seven) 0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
627 (Assert (eq (mod -35 ,seven) 0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
628 (Assert (eq (mod 35 (- ,seven)) 0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
629 (Assert (eq (mod -35 (- ,seven)) 0)) |
428 | 630 |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
631 (Assert (= (mod ,seven 2.0) 1.0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
632 (Assert (= (mod ,seven -2.0) -1.0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
633 (Assert (= (mod (- ,seven) 2.0) 1.0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
634 (Assert (= (mod (- ,seven) -2.0) -1.0)) |
428 | 635 |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
636 (Assert (= (mod ,seven 4.0) 3.0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
637 (Assert (= (mod ,seven -4.0) -1.0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
638 (Assert (= (mod (- ,seven) 4.0) 1.0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
639 (Assert (= (mod (- ,seven) -4.0) -3.0)) |
428 | 640 |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
641 (Assert (eq (% 0 ,seven) 0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
642 (Assert (eq (% 0 (- ,seven)) 0)) |
428 | 643 |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
644 (Assert (eq (mod 0 ,seven) 0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
645 (Assert (eq (mod 0 (- ,seven)) 0)) |
428 | 646 |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
647 (Assert (= (mod 0.0 ,seven) 0.0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
648 (Assert (= (mod 0.0 (- ,seven)) 0.0))))) |
428 | 649 |
650 (division-test 7) | |
651 (division-test ?\07) | |
652 (division-test (Int-to-Marker 7))) | |
653 | |
1983 | 654 (when (featurep 'bignum) |
655 (let ((big (+ (* 7 most-positive-fixnum 6))) | |
656 (negbig (- (* 7 most-negative-fixnum 6)))) | |
657 (= (% big (1+ most-positive-fixnum)) most-positive-fixnum) | |
658 (= (% negbig (1- most-negative-fixnum)) most-negative-fixnum) | |
659 (= (mod big (1+ most-positive-fixnum)) most-positive-fixnum) | |
660 (= (mod negbig (1- most-negative-fixnum)) most-negative-fixnum))) | |
428 | 661 |
662 ;;----------------------------------------------------- | |
663 ;; Arithmetic comparison operations | |
664 ;;----------------------------------------------------- | |
665 (Check-Error wrong-number-of-arguments (=)) | |
666 (Check-Error wrong-number-of-arguments (<)) | |
667 (Check-Error wrong-number-of-arguments (>)) | |
668 (Check-Error wrong-number-of-arguments (<=)) | |
669 (Check-Error wrong-number-of-arguments (>=)) | |
670 (Check-Error wrong-number-of-arguments (/=)) | |
671 | |
672 ;; One argument always yields t | |
673 (loop for x in `(1 1.0 ,(Int-to-Marker 1) ?z) do | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
674 (Assert (eq t (= x)) x) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
675 (Assert (eq t (< x)) x) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
676 (Assert (eq t (> x)) x) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
677 (Assert (eq t (>= x)) x) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
678 (Assert (eq t (<= x)) x) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
679 (Assert (eq t (/= x)) x) |
428 | 680 ) |
681 | |
682 ;; Type checking | |
683 (Check-Error wrong-type-argument (= 'foo 1)) | |
684 (Check-Error wrong-type-argument (<= 'foo 1)) | |
685 (Check-Error wrong-type-argument (>= 'foo 1)) | |
686 (Check-Error wrong-type-argument (< 'foo 1)) | |
687 (Check-Error wrong-type-argument (> 'foo 1)) | |
688 (Check-Error wrong-type-argument (/= 'foo 1)) | |
689 | |
690 ;; Meat | |
691 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01)) | |
692 (dolist (two '(2 2.0 ?\02)) | |
2056 | 693 (Assert (< one two) (list one two)) |
694 (Assert (<= one two) (list one two)) | |
695 (Assert (<= two two) two) | |
696 (Assert (> two one) (list one two)) | |
697 (Assert (>= two one) (list one two)) | |
698 (Assert (>= two two) two) | |
699 (Assert (/= one two) (list one two)) | |
700 (Assert (not (/= two two)) two) | |
701 (Assert (not (< one one)) one) | |
702 (Assert (not (> one one)) one) | |
703 (Assert (<= one one two two) (list one two)) | |
704 (Assert (not (< one one two two)) (list one two)) | |
705 (Assert (>= two two one one) (list one two)) | |
706 (Assert (not (> two two one one)) (list one two)) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
707 (Assert (= one one one) one) |
2056 | 708 (Assert (not (= one one one two)) (list one two)) |
709 (Assert (not (/= one two one)) (list one two)) | |
428 | 710 )) |
711 | |
712 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01)) | |
713 (dolist (two '(2 2.0 ?\02)) | |
2056 | 714 (Assert (< one two) (list one two)) |
715 (Assert (<= one two) (list one two)) | |
716 (Assert (<= two two) two) | |
717 (Assert (> two one) (list one two)) | |
718 (Assert (>= two one) (list one two)) | |
719 (Assert (>= two two) two) | |
720 (Assert (/= one two) (list one two)) | |
721 (Assert (not (/= two two)) two) | |
722 (Assert (not (< one one)) one) | |
723 (Assert (not (> one one)) one) | |
724 (Assert (<= one one two two) (list one two)) | |
725 (Assert (not (< one one two two)) (list one two)) | |
726 (Assert (>= two two one one) (list one two)) | |
727 (Assert (not (> two two one one)) (list one two)) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
728 (Assert (= one one one) one) |
2056 | 729 (Assert (not (= one one one two)) (list one two)) |
730 (Assert (not (/= one two one)) (list one two)) | |
428 | 731 )) |
732 | |
733 ;; ad-hoc | |
734 (Assert (< 1 2)) | |
735 (Assert (< 1 2 3 4 5 6)) | |
736 (Assert (not (< 1 1))) | |
737 (Assert (not (< 2 1))) | |
738 | |
739 | |
740 (Assert (not (< 1 1))) | |
741 (Assert (< 1 2 3 4 5 6)) | |
742 (Assert (<= 1 2 3 4 5 6)) | |
743 (Assert (<= 1 2 3 4 5 6 6)) | |
744 (Assert (not (< 1 2 3 4 5 6 6))) | |
745 (Assert (<= 1 1)) | |
746 | |
747 (Assert (not (eq (point) (point-marker)))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
748 (Assert (= 1 (Int-to-Marker 1))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
749 (Assert (= (point) (point-marker))) |
428 | 750 |
1983 | 751 (when (featurep 'bignum) |
752 (let ((big1 (1+ most-positive-fixnum)) | |
753 (big2 (* 10 most-positive-fixnum)) | |
754 (small1 (1- most-negative-fixnum)) | |
755 (small2 (* 10 most-negative-fixnum))) | |
756 (Assert (< small2 small1 most-negative-fixnum most-positive-fixnum big1 | |
757 big2)) | |
758 (Assert (<= small2 small1 most-negative-fixnum most-positive-fixnum big1 | |
759 big2)) | |
760 (Assert (> big2 big1 most-positive-fixnum most-negative-fixnum small1 | |
761 small2)) | |
762 (Assert (>= big2 big1 most-positive-fixnum most-negative-fixnum small1 | |
763 small2)) | |
764 (Assert (/= small2 small1 most-negative-fixnum most-positive-fixnum big1 | |
765 big2)))) | |
766 | |
767 (when (featurep 'ratio) | |
768 (let ((big1 (div (* 10 most-positive-fixnum) 4)) | |
769 (big2 (div (* 5 most-positive-fixnum) 2)) | |
770 (big3 (div (* 7 most-positive-fixnum) 2)) | |
771 (small1 (div (* 10 most-negative-fixnum) 4)) | |
772 (small2 (div (* 5 most-negative-fixnum) 2)) | |
773 (small3 (div (* 7 most-negative-fixnum) 2))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
774 (Assert (= big1 big2)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
775 (Assert (= small1 small2)) |
1983 | 776 (Assert (< small3 small1 most-negative-fixnum most-positive-fixnum big1 |
777 big3)) | |
778 (Assert (<= small3 small2 small1 most-negative-fixnum most-positive-fixnum | |
779 big1 big2 big3)) | |
780 (Assert (> big3 big1 most-positive-fixnum most-negative-fixnum small1 | |
781 small3)) | |
782 (Assert (>= big3 big2 big1 most-positive-fixnum most-negative-fixnum | |
783 small1 small2 small3)) | |
784 (Assert (/= big3 big1 most-positive-fixnum most-negative-fixnum small1 | |
785 small3)))) | |
786 | |
428 | 787 ;;----------------------------------------------------- |
788 ;; testing list-walker functions | |
789 ;;----------------------------------------------------- | |
790 (macrolet | |
791 ((test-fun | |
792 (fun) | |
793 `(progn | |
794 (Check-Error wrong-number-of-arguments (,fun)) | |
795 (Check-Error wrong-number-of-arguments (,fun nil)) | |
5346
b4ef3128160c
Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5339
diff
changeset
|
796 (Check-Error (malformed-list wrong-type-argument) (,fun nil 1)) |
428 | 797 ,@(loop for n in '(1 2 2000) |
798 collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n)))))) | |
799 (test-funs (&rest funs) `(progn ,@(loop for fun in funs collect `(test-fun ,fun))))) | |
800 | |
5346
b4ef3128160c
Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5339
diff
changeset
|
801 (test-funs member* member memq |
b4ef3128160c
Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5339
diff
changeset
|
802 assoc* assoc assq |
b4ef3128160c
Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5339
diff
changeset
|
803 rassoc* rassoc rassq |
b4ef3128160c
Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5339
diff
changeset
|
804 delete* delete delq |
b4ef3128160c
Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5339
diff
changeset
|
805 remove* remove remq |
b4ef3128160c
Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5339
diff
changeset
|
806 old-member old-memq |
b4ef3128160c
Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5339
diff
changeset
|
807 old-assoc old-assq |
b4ef3128160c
Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5339
diff
changeset
|
808 old-rassoc old-rassq |
b4ef3128160c
Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5339
diff
changeset
|
809 old-delete old-delq |
b4ef3128160c
Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5339
diff
changeset
|
810 remassoc remassq remrassoc remrassq)) |
428 | 811 |
812 (let ((x '((1 . 2) 3 (4 . 5)))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
813 (Assert (eq (assoc 1 x) (car x))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
814 (Assert (eq (assq 1 x) (car x))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
815 (Assert (eq (rassoc 1 x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
816 (Assert (eq (rassq 1 x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
817 (Assert (eq (assoc 2 x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
818 (Assert (eq (assq 2 x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
819 (Assert (eq (rassoc 2 x) (car x))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
820 (Assert (eq (rassq 2 x) (car x))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
821 (Assert (eq (assoc 3 x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
822 (Assert (eq (assq 3 x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
823 (Assert (eq (rassoc 3 x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
824 (Assert (eq (rassq 3 x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
825 (Assert (eq (assoc 4 x) (caddr x))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
826 (Assert (eq (assq 4 x) (caddr x))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
827 (Assert (eq (rassoc 4 x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
828 (Assert (eq (rassq 4 x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
829 (Assert (eq (assoc 5 x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
830 (Assert (eq (assq 5 x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
831 (Assert (eq (rassoc 5 x) (caddr x))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
832 (Assert (eq (rassq 5 x) (caddr x))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
833 (Assert (eq (assoc 6 x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
834 (Assert (eq (assq 6 x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
835 (Assert (eq (rassoc 6 x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
836 (Assert (eq (rassq 6 x) nil))) |
428 | 837 |
838 (let ((x '(("1" . "2") "3" ("4" . "5")))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
839 (Assert (eq (assoc "1" x) (car x))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
840 (Assert (eq (assq "1" x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
841 (Assert (eq (rassoc "1" x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
842 (Assert (eq (rassq "1" x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
843 (Assert (eq (assoc "2" x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
844 (Assert (eq (assq "2" x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
845 (Assert (eq (rassoc "2" x) (car x))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
846 (Assert (eq (rassq "2" x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
847 (Assert (eq (assoc "3" x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
848 (Assert (eq (assq "3" x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
849 (Assert (eq (rassoc "3" x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
850 (Assert (eq (rassq "3" x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
851 (Assert (eq (assoc "4" x) (caddr x))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
852 (Assert (eq (assq "4" x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
853 (Assert (eq (rassoc "4" x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
854 (Assert (eq (rassq "4" x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
855 (Assert (eq (assoc "5" x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
856 (Assert (eq (assq "5" x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
857 (Assert (eq (rassoc "5" x) (caddr x))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
858 (Assert (eq (rassq "5" x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
859 (Assert (eq (assoc "6" x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
860 (Assert (eq (assq "6" x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
861 (Assert (eq (rassoc "6" x) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
862 (Assert (eq (rassq "6" x) nil))) |
428 | 863 |
864 (flet ((a () (list '(1 . 2) 3 '(4 . 5)))) | |
865 (Assert (let* ((x (a)) (y (remassoc 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
866 (Assert (let* ((x (a)) (y (remassq 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
867 (Assert (let* ((x (a)) (y (remrassoc 1 x))) (and (eq x y) (equal y (a))))) | |
868 (Assert (let* ((x (a)) (y (remrassq 1 x))) (and (eq x y) (equal y (a))))) | |
869 | |
870 (Assert (let* ((x (a)) (y (remassoc 2 x))) (and (eq x y) (equal y (a))))) | |
871 (Assert (let* ((x (a)) (y (remassq 2 x))) (and (eq x y) (equal y (a))))) | |
872 (Assert (let* ((x (a)) (y (remrassoc 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
873 (Assert (let* ((x (a)) (y (remrassq 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
874 | |
875 (Assert (let* ((x (a)) (y (remassoc 3 x))) (and (eq x y) (equal y (a))))) | |
876 (Assert (let* ((x (a)) (y (remassq 3 x))) (and (eq x y) (equal y (a))))) | |
877 (Assert (let* ((x (a)) (y (remrassoc 3 x))) (and (eq x y) (equal y (a))))) | |
878 (Assert (let* ((x (a)) (y (remrassq 3 x))) (and (eq x y) (equal y (a))))) | |
879 | |
880 (Assert (let* ((x (a)) (y (remassoc 4 x))) (and (eq x y) (equal y '((1 . 2) 3))))) | |
881 (Assert (let* ((x (a)) (y (remassq 4 x))) (and (eq x y) (equal y '((1 . 2) 3))))) | |
882 (Assert (let* ((x (a)) (y (remrassoc 4 x))) (and (eq x y) (equal y (a))))) | |
883 (Assert (let* ((x (a)) (y (remrassq 4 x))) (and (eq x y) (equal y (a))))) | |
884 | |
885 (Assert (let* ((x (a)) (y (remassoc 5 x))) (and (eq x y) (equal y (a))))) | |
886 (Assert (let* ((x (a)) (y (remassq 5 x))) (and (eq x y) (equal y (a))))) | |
887 (Assert (let* ((x (a)) (y (remrassoc 5 x))) (and (eq x y) (equal y '((1 . 2) 3))))) | |
888 (Assert (let* ((x (a)) (y (remrassq 5 x))) (and (eq x y) (equal y '((1 . 2) 3))))) | |
889 | |
890 (Assert (let* ((x (a)) (y (remassoc 6 x))) (and (eq x y) (equal y (a))))) | |
891 (Assert (let* ((x (a)) (y (remassq 6 x))) (and (eq x y) (equal y (a))))) | |
892 (Assert (let* ((x (a)) (y (remrassoc 6 x))) (and (eq x y) (equal y (a))))) | |
893 (Assert (let* ((x (a)) (y (remrassq 6 x))) (and (eq x y) (equal y (a))))) | |
894 | |
895 (Assert (let* ((x (a)) (y (delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) | |
896 (Assert (let* ((x (a)) (y (delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) | |
897 (Assert (let* ((x (a)) (y (old-delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) | |
898 (Assert (let* ((x (a)) (y (old-delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) | |
899 | |
900 (Assert (let* ((x (a)) (y (delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
901 (Assert (let* ((x (a)) (y (delq '(1 . 2) x))) (and (eq x y) (equal y (a))))) | |
902 (Assert (let* ((x (a)) (y (old-delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
903 (Assert (let* ((x (a)) (y (old-delq '(1 . 2) x))) (and (eq x y) (equal y (a))))) | |
904 ) | |
905 | |
906 | |
907 | |
908 (flet ((a () (list '("1" . "2") "3" '("4" . "5")))) | |
909 (Assert (let* ((x (a)) (y (remassoc "1" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5")))))) | |
910 (Assert (let* ((x (a)) (y (remassq "1" x))) (and (eq x y) (equal y (a))))) | |
911 (Assert (let* ((x (a)) (y (remrassoc "1" x))) (and (eq x y) (equal y (a))))) | |
912 (Assert (let* ((x (a)) (y (remrassq "1" x))) (and (eq x y) (equal y (a))))) | |
913 | |
914 (Assert (let* ((x (a)) (y (remassoc "2" x))) (and (eq x y) (equal y (a))))) | |
915 (Assert (let* ((x (a)) (y (remassq "2" x))) (and (eq x y) (equal y (a))))) | |
916 (Assert (let* ((x (a)) (y (remrassoc "2" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5")))))) | |
917 (Assert (let* ((x (a)) (y (remrassq "2" x))) (and (eq x y) (equal y (a))))) | |
918 | |
919 (Assert (let* ((x (a)) (y (remassoc "3" x))) (and (eq x y) (equal y (a))))) | |
920 (Assert (let* ((x (a)) (y (remassq "3" x))) (and (eq x y) (equal y (a))))) | |
921 (Assert (let* ((x (a)) (y (remrassoc "3" x))) (and (eq x y) (equal y (a))))) | |
922 (Assert (let* ((x (a)) (y (remrassq "3" x))) (and (eq x y) (equal y (a))))) | |
923 | |
924 (Assert (let* ((x (a)) (y (remassoc "4" x))) (and (eq x y) (equal y '(("1" . "2") "3"))))) | |
925 (Assert (let* ((x (a)) (y (remassq "4" x))) (and (eq x y) (equal y (a))))) | |
926 (Assert (let* ((x (a)) (y (remrassoc "4" x))) (and (eq x y) (equal y (a))))) | |
927 (Assert (let* ((x (a)) (y (remrassq "4" x))) (and (eq x y) (equal y (a))))) | |
928 | |
929 (Assert (let* ((x (a)) (y (remassoc "5" x))) (and (eq x y) (equal y (a))))) | |
930 (Assert (let* ((x (a)) (y (remassq "5" x))) (and (eq x y) (equal y (a))))) | |
931 (Assert (let* ((x (a)) (y (remrassoc "5" x))) (and (eq x y) (equal y '(("1" . "2") "3"))))) | |
932 (Assert (let* ((x (a)) (y (remrassq "5" x))) (and (eq x y) (equal y (a))))) | |
933 | |
934 (Assert (let* ((x (a)) (y (remassoc "6" x))) (and (eq x y) (equal y (a))))) | |
935 (Assert (let* ((x (a)) (y (remassq "6" x))) (and (eq x y) (equal y (a))))) | |
936 (Assert (let* ((x (a)) (y (remrassoc "6" x))) (and (eq x y) (equal y (a))))) | |
937 (Assert (let* ((x (a)) (y (remrassq "6" x))) (and (eq x y) (equal y (a)))))) | |
938 | |
939 ;;----------------------------------------------------- | |
940 ;; function-max-args, function-min-args | |
941 ;;----------------------------------------------------- | |
942 (defmacro check-function-argcounts (fun min max) | |
943 `(progn | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
944 (Assert (eq (function-min-args ,fun) ,min)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
945 (Assert (eq (function-max-args ,fun) ,max)))) |
428 | 946 |
947 (check-function-argcounts 'prog1 1 nil) ; special form | |
948 (check-function-argcounts 'command-execute 1 3) ; normal subr | |
949 (check-function-argcounts 'funcall 1 nil) ; `MANY' subr | |
950 (check-function-argcounts 'garbage-collect 0 0) ; no args subr | |
951 | |
952 ;; Test interpreted and compiled functions | |
953 (loop for (arglist min max) in | |
954 '(((arg1 arg2 &rest args) 2 nil) | |
955 ((arg1 arg2 &optional arg3 arg4) 2 4) | |
956 ((arg1 arg2 &optional arg3 arg4 &rest args) 2 nil) | |
957 (() 0 0)) | |
958 do | |
959 (eval | |
960 `(progn | |
961 (defun test-fun ,arglist nil) | |
962 (check-function-argcounts '(lambda ,arglist nil) ,min ,max) | |
963 (check-function-argcounts (byte-compile '(lambda ,arglist nil)) ,min ,max)))) | |
964 | |
4575
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
965 ;; Test subr-arity. |
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
966 (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
|
967 '((let (1 . unevalled)) |
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
968 (prog1 (1 . unevalled)) |
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
969 (list (0 . many)) |
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
970 (type-of (1 . 1)) |
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
971 (garbage-collect (0 . 0))) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
972 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
|
973 |
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
974 (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
|
975 (lambda () (message "Hi there!")))) |
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
976 |
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
977 (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
|
978 |
428 | 979 ;;----------------------------------------------------- |
980 ;; Detection of cyclic variable indirection loops | |
981 ;;----------------------------------------------------- | |
982 (fset 'test-sym1 'test-sym1) | |
983 (Check-Error cyclic-function-indirection (test-sym1)) | |
984 | |
985 (fset 'test-sym1 'test-sym2) | |
986 (fset 'test-sym2 'test-sym1) | |
987 (Check-Error cyclic-function-indirection (test-sym1)) | |
988 (fmakunbound 'test-sym1) ; else macroexpand-internal infloops! | |
989 (fmakunbound 'test-sym2) | |
990 | |
991 ;;----------------------------------------------------- | |
992 ;; Test `type-of' | |
993 ;;----------------------------------------------------- | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
994 (Assert (eq (type-of load-path) 'cons)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
995 (Assert (eq (type-of obarray) 'vector)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
996 (Assert (eq (type-of 42) 'integer)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
997 (Assert (eq (type-of ?z) 'character)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
998 (Assert (eq (type-of "42") 'string)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
999 (Assert (eq (type-of 'foo) 'symbol)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1000 (Assert (eq (type-of (selected-device)) 'device)) |
428 | 1001 |
1002 ;;----------------------------------------------------- | |
1003 ;; Test mapping functions | |
1004 ;;----------------------------------------------------- | |
1005 (Check-Error wrong-type-argument (mapcar #'identity (current-buffer))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1006 (Assert (equal (mapcar #'identity load-path) load-path)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1007 (Assert (equal (mapcar #'identity '(1 2 3)) '(1 2 3))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1008 (Assert (equal (mapcar #'identity "123") '(?1 ?2 ?3))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1009 (Assert (equal (mapcar #'identity [1 2 3]) '(1 2 3))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1010 (Assert (equal (mapcar #'identity #*010) '(0 1 0))) |
428 | 1011 |
1012 (let ((z 0) (list (make-list 1000 1))) | |
1013 (mapc (lambda (x) (incf z x)) list) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1014 (Assert (eq 1000 z))) |
428 | 1015 |
1016 (Check-Error wrong-type-argument (mapvector #'identity (current-buffer))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1017 (Assert (equal (mapvector #'identity '(1 2 3)) [1 2 3])) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1018 (Assert (equal (mapvector #'identity "123") [?1 ?2 ?3])) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1019 (Assert (equal (mapvector #'identity [1 2 3]) [1 2 3])) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1020 (Assert (equal (mapvector #'identity #*010) [0 1 0])) |
428 | 1021 |
1022 (Check-Error wrong-type-argument (mapconcat #'identity (current-buffer) "foo")) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1023 (Assert (equal (mapconcat #'identity '("1" "2" "3") "|") "1|2|3")) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1024 (Assert (equal (mapconcat #'identity ["1" "2" "3"] "|") "1|2|3")) |
428 | 1025 |
434 | 1026 ;; The following 2 functions used to crash XEmacs via mapcar1(). |
1027 ;; We don't test the actual values of the mapcar, since they're undefined. | |
446 | 1028 (Assert |
434 | 1029 (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3)))) |
1030 (mapcar | |
1031 (lambda (y) | |
1032 "Devious evil mapping function" | |
1033 (when (eq (car y) 2) ; go out onto a limb | |
1034 (setcdr x nil) ; cut it off behind us | |
1035 (garbage-collect)) ; are we riding a magic broomstick? | |
1036 (car y)) ; sorry, hard landing | |
1037 x))) | |
1038 | |
446 | 1039 (Assert |
434 | 1040 (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3)))) |
1041 (mapcar | |
1042 (lambda (y) | |
1043 "Devious evil mapping function" | |
1044 (when (eq (car y) 1) | |
1045 (setcdr (cdr x) 42)) ; drop a brick wall onto the freeway | |
1046 (car y)) | |
1047 x))) | |
1048 | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1049 (Assert (eql |
5034
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4906
diff
changeset
|
1050 (length (multiple-value-list |
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4906
diff
changeset
|
1051 (car (mapcar #'(lambda (argument) (floor argument)) (list pi e))))) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1052 1) |
5034
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4906
diff
changeset
|
1053 "checking multiple values are correctly discarded in mapcar") |
1b96882bdf37
Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4906
diff
changeset
|
1054 |
5299
28651c24b3f8
Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents:
5295
diff
changeset
|
1055 (let ((malformed-list '(1 2 3 4 hi there . tail))) |
28651c24b3f8
Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents:
5295
diff
changeset
|
1056 (Check-Error malformed-list (mapcar #'identity malformed-list)) |
28651c24b3f8
Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents:
5295
diff
changeset
|
1057 (Check-Error malformed-list (map nil #'eq [1 2 3 4] |
28651c24b3f8
Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents:
5295
diff
changeset
|
1058 malformed-list)) |
28651c24b3f8
Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents:
5295
diff
changeset
|
1059 (Check-Error malformed-list (list-length malformed-list))) |
28651c24b3f8
Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents:
5295
diff
changeset
|
1060 |
428 | 1061 ;;----------------------------------------------------- |
1062 ;; Test vector functions | |
1063 ;;----------------------------------------------------- | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1064 (Assert (equal [1 2 3] [1 2 3])) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1065 (Assert (equal [] [])) |
428 | 1066 (Assert (not (equal [1 2 3] []))) |
1067 (Assert (not (equal [1 2 3] [1 2 4]))) | |
1068 (Assert (not (equal [0 2 3] [1 2 3]))) | |
1069 (Assert (not (equal [1 2 3] [1 2 3 4]))) | |
1070 (Assert (not (equal [1 2 3 4] [1 2 3]))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1071 (Assert (equal (vector 1 2 3) [1 2 3])) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1072 (Assert (equal (make-vector 3 1) [1 1 1])) |
428 | 1073 |
1074 ;;----------------------------------------------------- | |
1075 ;; Test bit-vector functions | |
1076 ;;----------------------------------------------------- | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1077 (Assert (equal #*010 #*010)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1078 (Assert (equal #* #*)) |
428 | 1079 (Assert (not (equal #*010 #*011))) |
1080 (Assert (not (equal #*010 #*))) | |
1081 (Assert (not (equal #*110 #*010))) | |
1082 (Assert (not (equal #*010 #*0100))) | |
1083 (Assert (not (equal #*0101 #*010))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1084 (Assert (equal (bit-vector 0 1 0) #*010)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1085 (Assert (equal (make-bit-vector 3 1) #*111)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1086 (Assert (equal (make-bit-vector 3 0) #*000)) |
428 | 1087 |
1088 ;;----------------------------------------------------- | |
1089 ;; Test buffer-local variables used as (ugh!) function parameters | |
1090 ;;----------------------------------------------------- | |
1091 (make-local-variable 'test-emacs-buffer-local-variable) | |
1092 (byte-compile | |
1093 (defun test-emacs-buffer-local-parameter (test-emacs-buffer-local-variable) | |
1094 (setq test-emacs-buffer-local-variable nil))) | |
1095 (test-emacs-buffer-local-parameter nil) | |
1096 | |
1097 ;;----------------------------------------------------- | |
1098 ;; Test split-string | |
1099 ;;----------------------------------------------------- | |
1425 | 1100 ;; Keep nulls, explicit SEPARATORS |
1101 ;; Hrvoje didn't like the next 3 tests so I'm disabling them for now. -sb | |
1102 ;; I assume Hrvoje worried about the possibility of infloops. -sjt | |
1103 (when test-harness-risk-infloops | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1104 (Assert (equal (split-string "foo" "") '("" "f" "o" "o" ""))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1105 (Assert (equal (split-string "foo" "^") '("" "foo"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1106 (Assert (equal (split-string "foo" "$") '("foo" "")))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1107 (Assert (equal (split-string "foo,bar" ",") '("foo" "bar"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1108 (Assert (equal (split-string ",foo,bar," ",") '("" "foo" "bar" ""))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1109 (Assert (equal (split-string ",foo,bar," "^,") '("" "foo,bar,"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1110 (Assert (equal (split-string ",foo,bar," ",$") '(",foo,bar" ""))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1111 (Assert (equal (split-string ",foo,,bar," ",") '("" "foo" "" "bar" ""))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1112 (Assert (equal (split-string "foo,,,bar" ",") '("foo" "" "" "bar"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1113 (Assert (equal (split-string "foo,,bar,," ",") '("foo" "" "bar" "" ""))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1114 (Assert (equal (split-string "foo,,bar" ",+") '("foo" "bar"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1115 (Assert (equal (split-string ",foo,,bar," ",+") '("" "foo" "bar" ""))) |
1425 | 1116 ;; Omit nulls, explicit SEPARATORS |
1117 (when test-harness-risk-infloops | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1118 (Assert (equal (split-string "foo" "" t) '("f" "o" "o"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1119 (Assert (equal (split-string "foo" "^" t) '("foo"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1120 (Assert (equal (split-string "foo" "$" t) '("foo")))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1121 (Assert (equal (split-string "foo,bar" "," t) '("foo" "bar"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1122 (Assert (equal (split-string ",foo,bar," "," t) '("foo" "bar"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1123 (Assert (equal (split-string ",foo,bar," "^," t) '("foo,bar,"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1124 (Assert (equal (split-string ",foo,bar," ",$" t) '(",foo,bar"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1125 (Assert (equal (split-string ",foo,,bar," "," t) '("foo" "bar"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1126 (Assert (equal (split-string "foo,,,bar" "," t) '("foo" "bar"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1127 (Assert (equal (split-string "foo,,bar,," "," t) '("foo" "bar"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1128 (Assert (equal (split-string "foo,,bar" ",+" t) '("foo" "bar"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1129 (Assert (equal (split-string ",foo,,bar," ",+" t) '("foo" "bar"))) |
1425 | 1130 ;; "Double-default" case |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1131 (Assert (equal (split-string "foo bar") '("foo" "bar"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1132 (Assert (equal (split-string " foo bar ") '("foo" "bar"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1133 (Assert (equal (split-string " foo bar ") '("foo" "bar"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1134 (Assert (equal (split-string "foo bar") '("foo" "bar"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1135 (Assert (equal (split-string "foo bar ") '("foo" "bar"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1136 (Assert (equal (split-string "foobar") '("foobar"))) |
1425 | 1137 ;; Semantics are identical to "double-default" case! Fool ya? |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1138 (Assert (equal (split-string "foo bar" nil t) '("foo" "bar"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1139 (Assert (equal (split-string " foo bar " nil t) '("foo" "bar"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1140 (Assert (equal (split-string " foo bar " nil t) '("foo" "bar"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1141 (Assert (equal (split-string "foo bar" nil t) '("foo" "bar"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1142 (Assert (equal (split-string "foo bar " nil t) '("foo" "bar"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1143 (Assert (equal (split-string "foobar" nil t) '("foobar"))) |
1425 | 1144 ;; Perverse "anti-double-default" case |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1145 (Assert (equal (split-string "foo bar" split-string-default-separators) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1146 '("foo" "bar"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1147 (Assert (equal (split-string " foo bar " split-string-default-separators) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1148 '("" "foo" "bar" ""))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1149 (Assert (equal (split-string " foo bar " split-string-default-separators) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1150 '("" "foo" "bar" ""))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1151 (Assert (equal (split-string "foo bar" split-string-default-separators) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1152 '("foo" "bar"))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1153 (Assert (equal (split-string "foo bar " split-string-default-separators) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1154 '("foo" "bar" ""))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1155 (Assert (equal (split-string "foobar" split-string-default-separators) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1156 '("foobar"))) |
434 | 1157 |
1158 ;;----------------------------------------------------- | |
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1159 ;; Test split-string-by-char |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1160 ;;----------------------------------------------------- |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1161 |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1162 (Assert |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1163 (equal |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1164 (split-string-by-char |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1165 #r"re\:ee:this\\is\\text\\\\:oo\ps: |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1166 Eine Sprache, die stagnirt, ist zu vergleichen mit einem See, dem der |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1167 bisherige Quellenzufluß versiegt oder abgeleitet wird. Aus dem Wasser, |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1168 worüber der Geist Gottes schwebte, wird Sumpf und Moder, worüber die |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1169 unreinen\: Geister brüten.\\ |
5036
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1170 Serum concentrations of vitamin E: (alpha-tocopherol) depend on the liver, |
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1171 which takes up the nutrient after the various forms are absorbed from the |
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1172 small intestine. The liver preferentially resecretes only alpha-tocopherol |
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1173 via the hepatic alpha-tocopherol transfer protein" |
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1174 ?: ?\\) |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1175 '("re:ee" "this\\is\\text\\\\" "oops" " |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1176 Eine Sprache, die stagnirt, ist zu vergleichen mit einem See, dem der |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1177 bisherige Quellenzufluß versiegt oder abgeleitet wird. Aus dem Wasser, |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1178 worüber der Geist Gottes schwebte, wird Sumpf und Moder, worüber die |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1179 unreinen: Geister brüten.\\ |
5036
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1180 Serum concentrations of vitamin E" " (alpha-tocopherol) depend on the liver, |
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1181 which takes up the nutrient after the various forms are absorbed from the |
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1182 small intestine. The liver preferentially resecretes only alpha-tocopherol |
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1183 via the hepatic alpha-tocopherol transfer protein"))) |
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1184 (Assert |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1185 (equal |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1186 (split-string-by-char |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1187 #r"re\:ee:this\\is\\text\\\\:oo\ps: |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1188 Eine Sprache, die stagnirt, ist zu vergleichen mit einem See, dem der |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1189 bisherige Quellenzufluß versiegt oder abgeleitet wird. Aus dem Wasser, |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1190 worüber der Geist Gottes schwebte, wird Sumpf und Moder, worüber die |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1191 unreinen\: Geister brüten.\\ |
5036
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1192 Serum concentrations of vitamin E: (alpha-tocopherol) depend on the liver, |
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1193 which takes up the nutrient after the various forms are absorbed from the |
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1194 small intestine. The liver preferentially resecretes only alpha-tocopherol |
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1195 via the hepatic alpha-tocopherol transfer protein" |
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1196 ?: ?\x00) |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1197 '("re\\" "ee" "this\\\\is\\\\text\\\\\\\\" "oo\\ps" " |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1198 Eine Sprache, die stagnirt, ist zu vergleichen mit einem See, dem der |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1199 bisherige Quellenzufluß versiegt oder abgeleitet wird. Aus dem Wasser, |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1200 worüber der Geist Gottes schwebte, wird Sumpf und Moder, worüber die |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1201 unreinen\\" " Geister brüten.\\\\ |
5036
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1202 Serum concentrations of vitamin E" " (alpha-tocopherol) depend on the liver, |
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1203 which takes up the nutrient after the various forms are absorbed from the |
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1204 small intestine. The liver preferentially resecretes only alpha-tocopherol |
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1205 via the hepatic alpha-tocopherol transfer protein"))) |
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1206 (Assert |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1207 (equal |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1208 (split-string-by-char |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1209 #r"re\:ee:this\\is\\text\\\\:oo\ps: |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1210 Eine Sprache, die stagnirt, ist zu vergleichen mit einem See, dem der |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1211 bisherige Quellenzufluß versiegt oder abgeleitet wird. Aus dem Wasser, |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1212 worüber der Geist Gottes schwebte, wird Sumpf und Moder, worüber die |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1213 unreinen\: Geister brüten.\\ |
5036
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1214 Serum concentrations of vitamin E: (alpha-tocopherol) depend on the liver, |
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1215 which takes up the nutrient after the various forms are absorbed from the |
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1216 small intestine. The liver preferentially resecretes only alpha-tocopherol |
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1217 via the hepatic alpha-tocopherol transfer protein" ?\\) |
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1218 '("re" ":ee:this" "" "is" "" "text" "" "" "" ":oo" "ps: |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1219 Eine Sprache, die stagnirt, ist zu vergleichen mit einem See, dem der |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1220 bisherige Quellenzufluß versiegt oder abgeleitet wird. Aus dem Wasser, |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1221 worüber der Geist Gottes schwebte, wird Sumpf und Moder, worüber die |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1222 unreinen" ": Geister brüten." "" " |
5036
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1223 Serum concentrations of vitamin E: (alpha-tocopherol) depend on the liver, |
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1224 which takes up the nutrient after the various forms are absorbed from the |
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1225 small intestine. The liver preferentially resecretes only alpha-tocopherol |
9624523604c5
Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents:
5035
diff
changeset
|
1226 via the hepatic alpha-tocopherol transfer protein"))) |
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1227 |
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
1228 ;;----------------------------------------------------- |
434 | 1229 ;; Test near-text buffer functions. |
1230 ;;----------------------------------------------------- | |
1231 (with-temp-buffer | |
1232 (erase-buffer) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1233 (Assert (eq (char-before) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1234 (Assert (eq (char-before (point)) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1235 (Assert (eq (char-before (point-marker)) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1236 (Assert (eq (char-before (point) (current-buffer)) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1237 (Assert (eq (char-before (point-marker) (current-buffer)) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1238 (Assert (eq (char-after) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1239 (Assert (eq (char-after (point)) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1240 (Assert (eq (char-after (point-marker)) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1241 (Assert (eq (char-after (point) (current-buffer)) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1242 (Assert (eq (char-after (point-marker) (current-buffer)) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1243 (Assert (eq (preceding-char) 0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1244 (Assert (eq (preceding-char (current-buffer)) 0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1245 (Assert (eq (following-char) 0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1246 (Assert (eq (following-char (current-buffer)) 0)) |
434 | 1247 (insert "foobar") |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1248 (Assert (eq (char-before) ?r)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1249 (Assert (eq (char-after) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1250 (Assert (eq (preceding-char) ?r)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1251 (Assert (eq (following-char) 0)) |
434 | 1252 (goto-char (point-min)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1253 (Assert (eq (char-before) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1254 (Assert (eq (char-after) ?f)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1255 (Assert (eq (preceding-char) 0)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1256 (Assert (eq (following-char) ?f)) |
434 | 1257 ) |
440 | 1258 |
1259 ;;----------------------------------------------------- | |
1260 ;; Test plist manipulation functions. | |
1261 ;;----------------------------------------------------- | |
1262 (let ((sym (make-symbol "test-symbol"))) | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1263 (Assert (eq t (get* sym t t))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1264 (Assert (eq t (get sym t t))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1265 (Assert (eq t (getf nil t t))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1266 (Assert (eq t (plist-get nil t t))) |
440 | 1267 (put sym 'bar 'baz) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1268 (Assert (eq 'baz (get sym 'bar))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1269 (Assert (eq 'baz (getf '(bar baz) 'bar))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1270 (Assert (eq 'baz (getf (symbol-plist sym) 'bar))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1271 (Assert (eq 2 (getf '(1 2) 1))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1272 (Assert (eq 4 (put sym 3 4))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1273 (Assert (eq 4 (get sym 3))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1274 (Assert (eq t (remprop sym 3))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1275 (Assert (eq nil (remprop sym 3))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1276 (Assert (eq 5 (get sym 3 5))) |
440 | 1277 ) |
442 | 1278 |
1279 (loop for obj in | |
1280 (list (make-symbol "test-symbol") | |
1281 "test-string" | |
1282 (make-extent nil nil nil) | |
1283 (make-face 'test-face)) | |
1284 do | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1285 (Assert (eq 2 (get obj ?1 2)) obj) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1286 (Assert (eq 4 (put obj ?3 4)) obj) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1287 (Assert (eq 4 (get obj ?3)) obj) |
442 | 1288 (when (or (stringp obj) (symbolp obj)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1289 (Assert (equal '(?3 4) (object-plist obj)) obj)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1290 (Assert (eq t (remprop obj ?3)) obj) |
442 | 1291 (when (or (stringp obj) (symbolp obj)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1292 (Assert (eq '() (object-plist obj)) obj)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1293 (Assert (eq nil (remprop obj ?3)) obj) |
442 | 1294 (when (or (stringp obj) (symbolp obj)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1295 (Assert (eq '() (object-plist obj)) obj)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1296 (Assert (eq 5 (get obj ?3 5)) obj) |
442 | 1297 ) |
1298 | |
1299 (Check-Error-Message | |
1300 error "Object type has no properties" | |
1301 (get 2 'property)) | |
1302 | |
1303 (Check-Error-Message | |
1304 error "Object type has no settable properties" | |
1305 (put (current-buffer) 'property 'value)) | |
1306 | |
1307 (Check-Error-Message | |
1308 error "Object type has no removable properties" | |
1309 (remprop ?3 'property)) | |
1310 | |
1311 (Check-Error-Message | |
1312 error "Object type has no properties" | |
1313 (object-plist (symbol-function 'car))) | |
1314 | |
1315 (Check-Error-Message | |
1316 error "Can't remove property from object" | |
1317 (remprop (make-extent nil nil nil) 'detachable)) | |
1318 | |
1319 ;;----------------------------------------------------- | |
1320 ;; Test subseq | |
1321 ;;----------------------------------------------------- | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1322 (Assert (equal (subseq nil 0) nil)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1323 (Assert (equal (subseq [1 2 3] 0) [1 2 3])) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1324 (Assert (equal (subseq [1 2 3] 1 -1) [2])) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1325 (Assert (equal (subseq "123" 0) "123")) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1326 (Assert (equal (subseq "1234" -3 -1) "23")) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1327 (Assert (equal (subseq #*0011 0) #*0011)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1328 (Assert (equal (subseq #*0011 -3 3) #*01)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1329 (Assert (equal (subseq '(1 2 3) 0) '(1 2 3))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1330 (Assert (equal (subseq '(1 2 3 4) -3 nil) '(2 3 4))) |
442 | 1331 |
446 | 1332 (Check-Error wrong-type-argument (subseq 3 2)) |
1333 (Check-Error args-out-of-range (subseq [1 2 3] -42)) | |
1334 (Check-Error args-out-of-range (subseq [1 2 3] 0 42)) | |
442 | 1335 |
1336 ;;----------------------------------------------------- | |
1337 ;; Time-related tests | |
1338 ;;----------------------------------------------------- | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1339 (Assert (= (length (current-time-string)) 24)) |
444 | 1340 |
1341 ;;----------------------------------------------------- | |
1342 ;; format test | |
1343 ;;----------------------------------------------------- | |
1344 (Assert (string= (format "%d" 10) "10")) | |
1345 (Assert (string= (format "%o" 8) "10")) | |
5295
2474dce7304e
Make sure (format "%b" 0) is non-zero length, print.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
1346 (Assert (string= (format "%b" 2) "10")) |
444 | 1347 (Assert (string= (format "%x" 31) "1f")) |
1348 (Assert (string= (format "%X" 31) "1F")) | |
5295
2474dce7304e
Make sure (format "%b" 0) is non-zero length, print.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
1349 (Assert (string= (format "%b" 0) "0")) |
2474dce7304e
Make sure (format "%b" 0) is non-zero length, print.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
1350 (Assert (string= (format "%b" 3) "11")) |
826 | 1351 ;; MS-Windows uses +002 in its floating-point numbers. #### We should |
1352 ;; perhaps fix this, but writing our own floating-point support in doprnt.c | |
1353 ;; is very hard. | |
1354 (Assert (or (string= (format "%e" 100) "1.000000e+02") | |
1355 (string= (format "%e" 100) "1.000000e+002"))) | |
1356 (Assert (or (string= (format "%E" 100) "1.000000E+02") | |
1357 (string= (format "%E" 100) "1.000000E+002"))) | |
1358 (Assert (or (string= (format "%E" 100) "1.000000E+02") | |
1359 (string= (format "%E" 100) "1.000000E+002"))) | |
444 | 1360 (Assert (string= (format "%f" 100) "100.000000")) |
448 | 1361 (Assert (string= (format "%7.3f" 12.12345) " 12.123")) |
1362 (Assert (string= (format "%07.3f" 12.12345) "012.123")) | |
1363 (Assert (string= (format "%-7.3f" 12.12345) "12.123 ")) | |
1364 (Assert (string= (format "%-07.3f" 12.12345) "12.123 ")) | |
444 | 1365 (Assert (string= (format "%g" 100.0) "100")) |
826 | 1366 (Assert (or (string= (format "%g" 0.000001) "1e-06") |
1367 (string= (format "%g" 0.000001) "1e-006"))) | |
444 | 1368 (Assert (string= (format "%g" 0.0001) "0.0001")) |
1369 (Assert (string= (format "%G" 100.0) "100")) | |
826 | 1370 (Assert (or (string= (format "%G" 0.000001) "1E-06") |
1371 (string= (format "%G" 0.000001) "1E-006"))) | |
444 | 1372 (Assert (string= (format "%G" 0.0001) "0.0001")) |
1373 | |
1374 (Assert (string= (format "%2$d%1$d" 10 20) "2010")) | |
1375 (Assert (string= (format "%-d" 10) "10")) | |
1376 (Assert (string= (format "%-4d" 10) "10 ")) | |
1377 (Assert (string= (format "%+d" 10) "+10")) | |
1378 (Assert (string= (format "%+d" -10) "-10")) | |
1379 (Assert (string= (format "%+4d" 10) " +10")) | |
1380 (Assert (string= (format "%+4d" -10) " -10")) | |
1381 (Assert (string= (format "% d" 10) " 10")) | |
1382 (Assert (string= (format "% d" -10) "-10")) | |
1383 (Assert (string= (format "% 4d" 10) " 10")) | |
1384 (Assert (string= (format "% 4d" -10) " -10")) | |
1385 (Assert (string= (format "%0d" 10) "10")) | |
1386 (Assert (string= (format "%0d" -10) "-10")) | |
1387 (Assert (string= (format "%04d" 10) "0010")) | |
1388 (Assert (string= (format "%04d" -10) "-010")) | |
1389 (Assert (string= (format "%*d" 4 10) " 10")) | |
1390 (Assert (string= (format "%*d" 4 -10) " -10")) | |
1391 (Assert (string= (format "%*d" -4 10) "10 ")) | |
1392 (Assert (string= (format "%*d" -4 -10) "-10 ")) | |
1393 (Assert (string= (format "%#d" 10) "10")) | |
1394 (Assert (string= (format "%#o" 8) "010")) | |
1395 (Assert (string= (format "%#x" 16) "0x10")) | |
826 | 1396 (Assert (or (string= (format "%#e" 100) "1.000000e+02") |
1397 (string= (format "%#e" 100) "1.000000e+002"))) | |
1398 (Assert (or (string= (format "%#E" 100) "1.000000E+02") | |
1399 (string= (format "%#E" 100) "1.000000E+002"))) | |
444 | 1400 (Assert (string= (format "%#f" 100) "100.000000")) |
1401 (Assert (string= (format "%#g" 100.0) "100.000")) | |
826 | 1402 (Assert (or (string= (format "%#g" 0.000001) "1.00000e-06") |
1403 (string= (format "%#g" 0.000001) "1.00000e-006"))) | |
444 | 1404 (Assert (string= (format "%#g" 0.0001) "0.000100000")) |
1405 (Assert (string= (format "%#G" 100.0) "100.000")) | |
826 | 1406 (Assert (or (string= (format "%#G" 0.000001) "1.00000E-06") |
1407 (string= (format "%#G" 0.000001) "1.00000E-006"))) | |
444 | 1408 (Assert (string= (format "%#G" 0.0001) "0.000100000")) |
1409 (Assert (string= (format "%.1d" 10) "10")) | |
1410 (Assert (string= (format "%.4d" 10) "0010")) | |
1411 ;; Combination of `-', `+', ` ', `0', `#', `.', `*' | |
448 | 1412 (Assert (string= (format "%-04d" 10) "10 ")) |
444 | 1413 (Assert (string= (format "%-*d" 4 10) "10 ")) |
1414 ;; #### Correctness of this behavior is questionable. | |
1415 ;; It might be better to signal error. | |
1416 (Assert (string= (format "%-*d" -4 10) "10 ")) | |
1417 ;; These behavior is not specified. | |
1418 ;; (format "%-+d" 10) | |
1419 ;; (format "%- d" 10) | |
1420 ;; (format "%-01d" 10) | |
1421 ;; (format "%-#4x" 10) | |
1422 ;; (format "%-.1d" 10) | |
1423 | |
1424 (Assert (string= (format "%01.1d" 10) "10")) | |
448 | 1425 (Assert (string= (format "%03.1d" 10) " 10")) |
1426 (Assert (string= (format "%01.3d" 10) "010")) | |
1427 (Assert (string= (format "%1.3d" 10) "010")) | |
444 | 1428 (Assert (string= (format "%3.1d" 10) " 10")) |
446 | 1429 |
448 | 1430 ;;; The following two tests used to use 1000 instead of 100, |
1431 ;;; but that merely found buffer overflow bugs in Solaris sprintf(). | |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1432 (Assert (= 102 (length (format "%.100f" 3.14)))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1433 (Assert (= 100 (length (format "%100f" 3.14)))) |
448 | 1434 |
446 | 1435 ;;; Check for 64-bit cleanness on LP64 platforms. |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1436 (Assert (= (read (format "%d" most-positive-fixnum)) most-positive-fixnum)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1437 (Assert (= (read (format "%ld" most-positive-fixnum)) most-positive-fixnum)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1438 (Assert (= (read (format "%u" most-positive-fixnum)) most-positive-fixnum)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1439 (Assert (= (read (format "%lu" most-positive-fixnum)) most-positive-fixnum)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1440 (Assert (= (read (format "%d" most-negative-fixnum)) most-negative-fixnum)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1441 (Assert (= (read (format "%ld" most-negative-fixnum)) most-negative-fixnum)) |
446 | 1442 |
4287 | 1443 ;; These used to crash. |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1444 (Assert (eql (read (format "%f" 1.2e+302)) 1.2e+302)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1445 (Assert (eql (read (format "%.1000d" 1)) 1)) |
4287 | 1446 |
446 | 1447 ;;; "%u" is undocumented, and Emacs Lisp has no unsigned type. |
1448 ;;; What to do if "%u" is used with a negative number? | |
1983 | 1449 ;;; For non-bignum XEmacsen, the most reasonable thing seems to be to print an |
1450 ;;; un-read-able number. The printed value might be useful to a human, if not | |
1451 ;;; to Emacs Lisp. | |
1452 ;;; For bignum XEmacsen, we make %u with a negative value throw an error. | |
1453 (if (featurep 'bignum) | |
1454 (progn | |
1455 (Check-Error wrong-type-argument (format "%u" most-negative-fixnum)) | |
1456 (Check-Error wrong-type-argument (format "%u" -1))) | |
1457 (Check-Error invalid-read-syntax (read (format "%u" most-negative-fixnum))) | |
1458 (Check-Error invalid-read-syntax (read (format "%u" -1)))) | |
448 | 1459 |
1460 ;; Check all-completions ignore element start with space. | |
1461 (Assert (not (all-completions "" '((" hidden" . "object"))))) | |
1462 (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
|
1463 |
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1464 (let* ((literal-with-uninterned |
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1465 '(first-element |
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1466 [#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
|
1467 #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
|
1468 #5=#:G32970 #6=#:G32972])) |
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1469 (print-readably t) |
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1470 (print-gensym t) |
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1471 (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
|
1472 (awkward-regexp "#1=#") |
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1473 (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
|
1474 printed-with-uninterned))) |
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1475 (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
|
1476 (1+ first-match-start))))) |
4580
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4575
diff
changeset
|
1477 |
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4575
diff
changeset
|
1478 (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
|
1479 (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
|
1480 (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
|
1481 (prin1-to-string char-table-with-symbol))) |
4580
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4575
diff
changeset
|
1482 "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
|
1483 |
4608
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1484 |
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1485 (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
|
1486 (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
|
1487 nil ".el"))) |
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1488 (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
|
1489 (erase-buffer) |
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1490 (insert |
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1491 "\ |
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1492 ;; 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
|
1493 ;; 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
|
1494 (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
|
1495 |
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1496 ;; 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
|
1497 (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
|
1498 old-char) |
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1499 (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
|
1500 (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
|
1501 (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
|
1502 (aset load-file-name 0 new-char) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1503 (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
|
1504 \"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
|
1505 |
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1506 (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
|
1507 (load-file-name new-load-file-name)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1508 (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
|
1509 \"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
|
1510 |
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1511 ") |
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1512 (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
|
1513 (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
|
1514 (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
|
1515 (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
|
1516 (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
|
1517 |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1518 (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
|
1519 (let ((q (floor x y))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1520 (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
|
1521 (cl-ceiling (x &optional y) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1522 (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
|
1523 (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
|
1524 (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
|
1525 (cl-truncate (x &optional y) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1526 (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
|
1527 (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
|
1528 (cl-round (x &optional y) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1529 (if y |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1530 (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
|
1531 (let* ((hy (/ y 2)) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1532 (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
|
1533 (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
|
1534 (= (+ hy hy) y) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1535 (/= (% (car res) 2) 0)) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1536 (list (1- (car res)) hy) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1537 (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
|
1538 (let ((q (round (/ x y)))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1539 (list q (- x (* q y))))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1540 (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
|
1541 (let ((q (round x))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1542 (list q (- x q)))))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1543 (Assert-rounding (first second &key |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1544 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
|
1545 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
|
1546 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
|
1547 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
|
1548 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
|
1549 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
|
1550 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
|
1551 one-ftruncate-result two-ftruncate-result) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1552 (Assert (equal one-floor-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1553 (floor first))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1554 (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
|
1555 first one-floor-result)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1556 (Assert (equal one-floor-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1557 (floor first 1))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1558 (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
|
1559 first one-floor-result)) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1560 (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
|
1561 (Check-Error arith-error (floor first 0.0)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1562 (Assert (equal two-floor-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1563 (floor first second))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1564 (format |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1565 "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
|
1566 first second two-floor-result)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1567 (Assert (equal (cl-floor first second) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1568 (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
|
1569 (format |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1570 "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
|
1571 first second)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1572 (Assert (equal one-ffloor-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1573 (ffloor first))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1574 (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
|
1575 first one-ffloor-result)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1576 (Assert (equal one-ffloor-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1577 (ffloor first 1))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1578 (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
|
1579 first one-ffloor-result)) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1580 (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
|
1581 (Check-Error arith-error (ffloor first 0.0)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1582 (Assert (equal two-ffloor-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1583 (ffloor first second))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1584 (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
|
1585 first second two-ffloor-result)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1586 (Assert (equal one-ceiling-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1587 (ceiling first))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1588 (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
|
1589 first one-ceiling-result)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1590 (Assert (equal one-ceiling-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1591 (ceiling first 1))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1592 (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
|
1593 first one-ceiling-result)) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1594 (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
|
1595 (Check-Error arith-error (ceiling first 0.0)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1596 (Assert (equal two-ceiling-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1597 (ceiling first second))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1598 (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
|
1599 first second two-ceiling-result)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1600 (Assert (equal (cl-ceiling first second) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1601 (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
|
1602 (format |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1603 "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
|
1604 first second)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1605 (Assert (equal one-fceiling-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1606 (fceiling first))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1607 (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
|
1608 first one-fceiling-result)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1609 (Assert (equal one-fceiling-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1610 (fceiling first 1))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1611 (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
|
1612 first one-fceiling-result)) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1613 (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
|
1614 (Check-Error arith-error (fceiling first 0.0)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1615 (Assert (equal two-fceiling-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1616 (fceiling first second))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1617 (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
|
1618 first second two-fceiling-result)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1619 (Assert (equal one-round-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1620 (round first))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1621 (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
|
1622 first one-round-result)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1623 (Assert (equal one-round-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1624 (round first 1))) |
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
1625 (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
|
1626 first one-round-result)) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1627 (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
|
1628 (Check-Error arith-error (round first 0.0)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1629 (Assert (equal two-round-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1630 (round first second))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1631 (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
|
1632 first second two-round-result)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1633 (Assert (equal one-fround-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1634 (fround first))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1635 (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
|
1636 first one-fround-result)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1637 (Assert (equal one-fround-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1638 (fround first 1))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1639 (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
|
1640 first one-fround-result)) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1641 (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
|
1642 (Check-Error arith-error (fround first 0.0)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1643 (Assert (equal two-fround-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1644 (fround first second))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1645 (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
|
1646 first second two-fround-result)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1647 (Assert (equal (cl-round first second) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1648 (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
|
1649 (format |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1650 "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
|
1651 first second)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1652 (Assert (equal one-truncate-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1653 (truncate first))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1654 (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
|
1655 first one-truncate-result)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1656 (Assert (equal one-truncate-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1657 (truncate first 1))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1658 (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
|
1659 first one-truncate-result)) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1660 (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
|
1661 (Check-Error arith-error (truncate first 0.0)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1662 (Assert (equal two-truncate-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1663 (truncate first second))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1664 (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
|
1665 first second two-truncate-result)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1666 (Assert (equal (cl-truncate first second) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1667 (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
|
1668 (format |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1669 "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
|
1670 first second)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1671 (Assert (equal one-ftruncate-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1672 (ftruncate first))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1673 (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
|
1674 first one-ftruncate-result)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1675 (Assert (equal one-ftruncate-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1676 (ftruncate first 1))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1677 (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
|
1678 first one-ftruncate-result)) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1679 (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
|
1680 (Check-Error arith-error (ftruncate first 0.0)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1681 (Assert (equal two-ftruncate-result (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
1682 (ftruncate first second))) |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1683 (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
|
1684 first second two-ftruncate-result))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1685 (Assert-rounding-floating (pie ee) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1686 (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
|
1687 (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
|
1688 "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
|
1689 (Assert-rounding pie ee |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1690 :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
|
1691 :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
|
1692 :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
|
1693 :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
|
1694 :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
|
1695 :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
|
1696 :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
|
1697 :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
|
1698 :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
|
1699 :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
|
1700 :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
|
1701 :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
|
1702 :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
|
1703 :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
|
1704 :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
|
1705 :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
|
1706 (- pie (* 1.0 ee)))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1707 (Assert-rounding pie (- ee) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1708 :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
|
1709 :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
|
1710 :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
|
1711 :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
|
1712 (- pie (* -2.0 (- ee)))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1713 :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
|
1714 :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
|
1715 :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
|
1716 :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
|
1717 (- pie (* -1.0 (- ee)))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1718 :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
|
1719 :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
|
1720 :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
|
1721 :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
|
1722 (- pie (* -1.0 (- ee)))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1723 :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
|
1724 :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
|
1725 :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
|
1726 :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
|
1727 (- pie (* -1.0 (- ee))))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1728 (Assert-rounding (- pie) ee |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1729 :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
|
1730 :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
|
1731 :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
|
1732 :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
|
1733 (- (- pie) (* -2.0 ee))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1734 :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
|
1735 :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
|
1736 :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
|
1737 :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
|
1738 (- (- pie) (* -1.0 ee))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1739 :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
|
1740 :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
|
1741 :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
|
1742 :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
|
1743 (- (- pie) (* -1.0 ee))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1744 :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
|
1745 :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
|
1746 :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
|
1747 :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
|
1748 (- (- pie) (* -1.0 ee)))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1749 (Assert-rounding (- pie) (- ee) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1750 :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
|
1751 :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
|
1752 :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
|
1753 :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
|
1754 (- (- pie) (* 1.0 (- ee)))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1755 :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
|
1756 :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
|
1757 :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
|
1758 :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
|
1759 (- (- pie) (* 2.0 (- ee)))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1760 :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
|
1761 :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
|
1762 :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
|
1763 :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
|
1764 (- (- pie) (* 1.0 (- ee)))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1765 :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
|
1766 :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
|
1767 :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
|
1768 :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
|
1769 (- (- pie) (* 1.0 (- ee))))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1770 (Assert-rounding ee pie |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1771 :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
|
1772 :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
|
1773 :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
|
1774 :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
|
1775 :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
|
1776 :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
|
1777 :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
|
1778 :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
|
1779 :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
|
1780 :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
|
1781 :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
|
1782 :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
|
1783 :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
|
1784 :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
|
1785 :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
|
1786 :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
|
1787 (Assert-rounding ee (- pie) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1788 :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
|
1789 :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
|
1790 :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
|
1791 :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
|
1792 (- ee (* -1.0 (- pie)))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1793 :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
|
1794 :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
|
1795 :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
|
1796 :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
|
1797 :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
|
1798 :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
|
1799 :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
|
1800 :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
|
1801 (- ee (* -1.0 (- pie)))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1802 :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
|
1803 :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
|
1804 :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
|
1805 :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
|
1806 ;; First, two integers: |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1807 (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
|
1808 :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
|
1809 :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
|
1810 :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
|
1811 :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
|
1812 :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
|
1813 :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
|
1814 :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
|
1815 (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
|
1816 :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
|
1817 :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
|
1818 :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
|
1819 :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
|
1820 :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
|
1821 :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
|
1822 :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
|
1823 (Assert-rounding -27 8 |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1824 :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
|
1825 :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
|
1826 :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
|
1827 :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
|
1828 :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
|
1829 :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
|
1830 :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
|
1831 :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
|
1832 (Assert-rounding -27 -8 |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1833 :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
|
1834 :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
|
1835 :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
|
1836 :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
|
1837 :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
|
1838 :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
|
1839 :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
|
1840 :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
|
1841 (Assert-rounding 8 27 |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1842 :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
|
1843 :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
|
1844 :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
|
1845 :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
|
1846 :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
|
1847 :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
|
1848 :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
|
1849 :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
|
1850 (Assert-rounding 8 -27 |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1851 :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
|
1852 :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
|
1853 :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
|
1854 :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
|
1855 :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
|
1856 :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
|
1857 :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
|
1858 :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
|
1859 (Assert-rounding -8 27 |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1860 :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
|
1861 :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
|
1862 :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
|
1863 :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
|
1864 :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
|
1865 :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
|
1866 :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
|
1867 :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
|
1868 (Assert-rounding -8 -27 |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1869 :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
|
1870 :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
|
1871 :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
|
1872 :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
|
1873 :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
|
1874 :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
|
1875 :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
|
1876 :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
|
1877 (Assert-rounding 32 4 |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1878 :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
|
1879 :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
|
1880 :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
|
1881 :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
|
1882 :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
|
1883 :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
|
1884 :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
|
1885 :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
|
1886 (Assert-rounding 32 -4 |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1887 :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
|
1888 :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
|
1889 :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
|
1890 :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
|
1891 :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
|
1892 :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
|
1893 :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
|
1894 :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
|
1895 (Assert-rounding 12 9 |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1896 :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
|
1897 :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
|
1898 :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
|
1899 :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
|
1900 :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
|
1901 :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
|
1902 :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
|
1903 :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
|
1904 (Assert-rounding 10 4 |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1905 :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
|
1906 :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
|
1907 :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
|
1908 :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
|
1909 :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
|
1910 :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
|
1911 :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
|
1912 :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
|
1913 (Assert-rounding 14 4 |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1914 :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
|
1915 :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
|
1916 :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
|
1917 :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
|
1918 :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
|
1919 :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
|
1920 :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
|
1921 :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
|
1922 ;; Now, two floats: |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1923 (Assert-rounding-floating pi e) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1924 (when (featurep 'bigfloat) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1925 (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
|
1926 (when (featurep 'bignum) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1927 (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
|
1928 "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
|
1929 (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
|
1930 :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
|
1931 :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
|
1932 :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
|
1933 :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
|
1934 :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
|
1935 :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
|
1936 :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
|
1937 :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
|
1938 :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
|
1939 :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
|
1940 :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
|
1941 :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
|
1942 :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
|
1943 :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
|
1944 :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
|
1945 :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
|
1946 (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
|
1947 :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
|
1948 :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
|
1949 :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
|
1950 :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
|
1951 :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
|
1952 :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
|
1953 :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
|
1954 :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
|
1955 :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
|
1956 :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
|
1957 :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
|
1958 :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
|
1959 :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
|
1960 :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
|
1961 :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
|
1962 :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
|
1963 (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
|
1964 :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
|
1965 :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
|
1966 :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
|
1967 :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
|
1968 :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
|
1969 :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
|
1970 :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
|
1971 :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
|
1972 :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
|
1973 :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
|
1974 :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
|
1975 :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
|
1976 :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
|
1977 :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
|
1978 :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
|
1979 :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
|
1980 ;; 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
|
1981 (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
|
1982 :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
|
1983 :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
|
1984 :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
|
1985 ;; 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
|
1986 ;; 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
|
1987 ;; 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
|
1988 ;; 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
|
1989 ;; 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
|
1990 :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
|
1991 :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
|
1992 :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
|
1993 :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
|
1994 :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
|
1995 :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
|
1996 :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
|
1997 :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
|
1998 :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
|
1999 :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
|
2000 :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
|
2001 :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
|
2002 ;; 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
|
2003 :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
|
2004 (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
|
2005 :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
|
2006 :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
|
2007 :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
|
2008 ;; 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
|
2009 :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
|
2010 :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
|
2011 :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
|
2012 :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
|
2013 :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
|
2014 :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
|
2015 :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
|
2016 :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
|
2017 :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
|
2018 :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
|
2019 :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
|
2020 :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
|
2021 ;; See commentary above |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2022 :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
|
2023 1))) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2024 (when (featurep 'ratio) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2025 (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
|
2026 :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
|
2027 :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
|
2028 :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
|
2029 :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
|
2030 :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
|
2031 :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
|
2032 :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
|
2033 :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
|
2034 (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
|
2035 :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
|
2036 :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
|
2037 :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
|
2038 :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
|
2039 :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
|
2040 :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
|
2041 :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
|
2042 :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
|
2043 |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2044 ;; 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
|
2045 ;; 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
|
2046 ;; 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
|
2047 ;; output here. |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2048 |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2049 (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
|
2050 (let ((print-readably t)) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2051 (princ first) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2052 (princ " ") |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2053 (princ second) |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2054 (princ " :one-floor-result ") |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2055 (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
|
2056 (princ " :two-floor-result ") |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2057 (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
|
2058 (princ " :one-ffloor-result ") |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2059 (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
|
2060 (princ " :two-ffloor-result ") |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2061 (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
|
2062 (princ " :one-ceiling-result ") |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2063 (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
|
2064 (princ " :two-ceiling-result ") |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2065 (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
|
2066 (princ " :one-fceiling-result ") |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2067 (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
|
2068 (princ " :two-fceiling-result ") |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2069 (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
|
2070 (princ " :one-round-result ") |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2071 (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
|
2072 (princ " :two-round-result ") |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2073 (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
|
2074 (princ " :one-fround-result ") |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2075 (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
|
2076 (princ " :two-fround-result ") |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2077 (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
|
2078 (princ " :one-truncate-result ") |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2079 (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
|
2080 (princ " :two-truncate-result ") |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2081 (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
|
2082 (princ " :one-ftruncate-result ") |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2083 (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
|
2084 (princ " :two-ftruncate-result ") |
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
2085 (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
|
2086 |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2087 ;; Multiple value tests. |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2088 |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2089 (flet ((foo (x y) |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2090 (floor (+ x y) y)) |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2091 (foo-zero (x y) |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2092 (values (floor (+ x y) y))) |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2093 (multiple-value-function-returning-t () |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2094 (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
|
2095 (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
|
2096 (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
|
2097 (function-throwing-multiple-values () |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2098 (let* ((listing '(0 3 4 nil "string" symbol)) |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2099 (tail listing) |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2100 elt) |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2101 (while t |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2102 (setq tail (cdr listing) |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2103 elt (car listing) |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2104 listing tail) |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2105 (when (null elt) |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2106 (throw 'VoN61Lo4Y (multiple-value-function-returning-t))))))) |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2107 (Assert |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2108 (= (+ (floor 5 3) (floor 19 4)) (+ 1 4) 5) |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2109 "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
|
2110 (Assert |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2111 (= 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
|
2112 "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
|
2113 (Assert |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2114 (= 1 (length (multiple-value-list |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2115 (foo-zero 400 (1+ most-positive-fixnum))))) |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2116 "Checking multiple values are discarded correctly when forced") |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2117 (Check-Error setting-constant (setq multiple-values-limit 20)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2118 (Assert (equal '(-1 1) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2119 (multiple-value-list (floor -3 4))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2120 "Checking #'multiple-value-list gives a sane result") |
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2121 (let ((ey 40000) |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2122 (bee "this is a string") |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2123 (cee #s(hash-table size 256 data (969 ?\xF9)))) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2124 (Assert (equal |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2125 (multiple-value-list (values ey bee cee)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2126 (multiple-value-list (values-list (list ey bee cee)))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2127 "Checking that #'values and #'values-list are correctly related") |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2128 (Assert (equal |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2129 (multiple-value-list (values-list (list ey bee cee))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2130 (multiple-value-list (apply #'values (list ey bee cee)))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2131 "Checking #'values-list and #'apply with #values are correctly related")) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2132 (Assert (= (multiple-value-call #'+ (floor 5 3) (floor 19 4)) 10) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2133 "Checking #'multiple-value-call gives reasonable results.") |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2134 (Assert (= (multiple-value-call (values '+ '*) (floor 5 3) (floor 19 4)) 10) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2135 "Checking #'multiple-value-call correct when first arg multiple.") |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2136 (Assert (= 1 (length (multiple-value-list (prog1 (floor pi) "hi there")))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2137 "Checking #'prog1 does not pass back multiple values") |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2138 (Assert (= 2 (length (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2139 (multiple-value-prog1 (floor pi) "hi there")))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2140 "Checking #'multiple-value-prog1 passes back multiple values") |
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2141 (multiple-value-bind (floored remainder this-is-nil) |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2142 (floor pi 1.0) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2143 (Assert (= floored 3) |
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2144 "Checking floored bound correctly") |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2145 (Assert (eql remainder (- pi 3.0)) |
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2146 "Checking remainder bound correctly") |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2147 (Assert (null this-is-nil) |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2148 "Checking trailing arg bound but nil")) |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2149 (let ((ey 40000) |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2150 (bee "this is a string") |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2151 (cee #s(hash-table size 256 data (969 ?\xF9)))) |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2152 (multiple-value-setq (ey bee cee) |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2153 (ffloor e 1.0)) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2154 (Assert (eql 2.0 ey) "Checking ey set correctly") |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2155 (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
|
2156 (Assert (null cee) "Checking cee set to nil correctly")) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2157 (Assert (= 3 (length (multiple-value-list (eval '(values nil t pi))))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2158 "Checking #'eval passes back multiple values") |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2159 (Assert (= 2 (length (multiple-value-list (apply #'floor '(5 3))))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2160 "Checking #'apply passes back multiple values") |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2161 (Assert (= 2 (length (multiple-value-list (funcall #'floor 5 3)))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2162 "Checking #'funcall passes back multiple values") |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2163 (Assert (equal '(1 2) (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2164 (multiple-value-call #'floor (values 5 3)))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2165 "Checking #'multiple-value-call passes back multiple values correctly") |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2166 (Assert (= 1 (length (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2167 (and (multiple-value-function-returning-nil) t)))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2168 "Checking multiple values from non-trailing forms discarded by #'and") |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2169 (Assert (= 5 (length (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2170 (and t (multiple-value-function-returning-nil))))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2171 "Checking multiple values from final forms not discarded by #'and") |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2172 (Assert (= 1 (length (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2173 (or (multiple-value-function-returning-t) t)))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2174 "Checking multiple values from non-trailing forms discarded by #'and") |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2175 (Assert (= 5 (length (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2176 (or nil (multiple-value-function-returning-t))))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2177 "Checking multiple values from final forms not discarded by #'and") |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2178 (Assert (= 1 (length (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2179 (cond ((multiple-value-function-returning-t)))))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2180 "Checking cond doesn't pass back multiple values in tests.") |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2181 (Assert (equal (list nil pi e radians-to-degrees degrees-to-radians) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2182 (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2183 (cond (t (multiple-value-function-returning-nil))))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2184 "Checking cond passes back multiple values in clauses.") |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2185 (Assert (= 1 (length (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2186 (prog1 (multiple-value-function-returning-nil))))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2187 "Checking prog1 discards multiple values correctly.") |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2188 (Assert (= 5 (length (multiple-value-list |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2189 (multiple-value-prog1 |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2190 (multiple-value-function-returning-nil))))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2191 "Checking multiple-value-prog1 passes back multiple values correctly.") |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2192 (Assert (equal (list t pi e degrees-to-radians radians-to-degrees) |
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2193 (multiple-value-list |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2194 (catch 'VoN61Lo4Y (function-throwing-multiple-values))))) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2195 (Assert (equal (list t pi e degrees-to-radians radians-to-degrees) |
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2196 (multiple-value-list |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2197 (loop |
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2198 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
|
2199 do (when (null eye) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2200 (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
|
2201 "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
|
2202 (Assert |
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
2203 (null (or)) |
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
2204 "Checking #'or behaves correctly with zero arguments.") |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2205 (Assert (eq t (and)) |
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
2206 "Checking #'and behaves correctly with zero arguments.") |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2207 (Assert (= (* 3.0 (- pi 3.0)) |
4742
4cf435fcebbc
Make #'letf not error if handed a #'values form.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4732
diff
changeset
|
2208 (letf (((values three one-four-one-five-nine) (floor pi))) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2209 (* three one-four-one-five-nine))) |
4742
4cf435fcebbc
Make #'letf not error if handed a #'values form.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4732
diff
changeset
|
2210 "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
|
2211 |
4792
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2212 ;; #'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
|
2213 (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
|
2214 (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
|
2215 (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
|
2216 (+base-chars+ (loop |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2217 with res = (make-string 96 ?\x20) |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2218 for int-char from #x20 to #x7f |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2219 for char being each element in-ref res |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2220 do (setf char (int-to-char int-char)) |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2221 finally return res))) |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2222 |
5188
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2223 (macrolet |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2224 ((equalp-equal-list-tests (equal-list) |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2225 (let (res) |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2226 (setq equal-lists (eval equal-list)) |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2227 (loop for li in equal-lists do |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2228 (loop for (x . tail) on li do |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2229 (loop for y in tail do |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2230 (push `(Assert (equalp ,(quote-maybe x) |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2231 ,(quote-maybe y))) res) |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2232 (push `(Assert (equalp ,(quote-maybe y) |
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2233 ,(quote-maybe x))) res) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2234 (push `(Assert (eql (equalp-hash ,(quote-maybe y)) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2235 (equalp-hash ,(quote-maybe x)))) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2236 res)))) |
5188
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2237 (cons 'progn (nreverse res)))) |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2238 (equalp-diff-list-tests (diff-list) |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2239 (let (res) |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2240 (setq diff-list (eval diff-list)) |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2241 (loop for (x . tail) on diff-list do |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2242 (loop for y in tail do |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2243 (push `(Assert (not (equalp ,(quote-maybe x) |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2244 ,(quote-maybe y)))) res) |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2245 (push `(Assert (not (equalp ,(quote-maybe y) |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2246 ,(quote-maybe x)))) res))) |
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2247 (cons 'progn (nreverse res)))) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2248 (Assert-equalp (object-one object-two &optional failing-case description) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2249 `(progn |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2250 (Assert (equalp ,object-one ,object-two) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2251 ,@(if failing-case |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2252 (list failing-case description))) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2253 (Assert (eql (equalp-hash ,object-one) (equalp-hash ,object-two)))))) |
5188
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2254 (equalp-equal-list-tests |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2255 `(,@(when (featurep 'bignum) |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2256 (read "((111111111111111111111111111111111111111111111111111 |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2257 111111111111111111111111111111111111111111111111111.0))")) |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2258 (0 0.0 0.000 -0 -0.0 -0.000 #b0 ,@(when (featurep 'ratio) '(0/5 -0/5))) |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2259 (21845 #b101010101010101 #x5555) |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2260 (1.5 1.500000000000000000000000000000000000000000000000000000000 |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2261 ,@(when (featurep 'ratio) '(3/2))) |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2262 ;; Can't use this, these values aren't `='. |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2263 ;;(-12345678901234567890123457890123457890123457890123457890123457890 |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2264 ;; -12345678901234567890123457890123457890123457890123457890123457890.0) |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2265 (-55 -55.000 ,@(when (featurep 'ratio) '(-110/2))))) |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2266 (equalp-diff-list-tests |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2267 `(0 1 2 3 1000 5000000000 |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2268 ,@(when (featurep 'bignum) |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2269 (read "(5555555555555555555555555555555555555 |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2270 -5555555555555555555555555555555555555)")) |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2271 -1 -2 -3 -1000 -5000000000 |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2272 1/2 1/3 2/3 8/2 355/113 |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2273 ,@(when (featurep 'ratio) (mapcar* #'/ '(3/2 3/2) '(0.2 0.7))) |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2274 55555555555555555555555555555555555555555/2718281828459045 |
000287f8053b
Be more careful about parentheses and number features, #'equalp tests
Aidan Kehoe <kehoea@parhasard.net>
parents:
5136
diff
changeset
|
2275 0.111111111111111111111111111111111111111111111111111111111111111 |
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2276 1e+300 1e+301 -1e+300 -1e+301)) |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2277 |
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2278 (Assert-equalp "hi there" "Hi There" |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2279 "checking equalp isn't case-sensitive") |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2280 (Assert-equalp |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2281 99 99.0 |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2282 "checking equalp compares numerical values of different types") |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2283 (Assert (null (equalp 99 ?c)) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2284 "checking equalp does not convert characters to numbers") |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2285 ;; Fixed in Hg d0ea57eb3de4. |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2286 (Assert (null (equalp "hi there" [hi there])) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2287 "checking equalp doesn't error with string and non-string") |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2288 (Assert-equalp |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2289 "ABCDEEFGH\u00CDJ" string-variable |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2290 "checking #'equalp is case-insensitive with an upcased constant") |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2291 (Assert-equalp |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2292 "abcdeefgh\xedj" string-variable |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2293 "checking #'equalp is case-insensitive with a downcased constant") |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2294 (Assert-equalp string-variable string-variable |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2295 "checking #'equalp works when handed the same string twice") |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2296 (Assert (equalp string-variable "aBcDeeFgH\u00Edj") |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2297 "check #'equalp is case-insensitive with a variable-cased constant") |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2298 (Assert-equalp "" (bit-vector) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2299 "check empty string and empty bit-vector are #'equalp.") |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2300 (Assert-equalp |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2301 (string) (bit-vector) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2302 "check empty string and empty bit-vector are #'equalp, no constants") |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2303 (Assert-equalp "hi there" (vector ?h ?i ?\ ?t ?h ?e ?r ?e) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2304 "check string and vector with same contents #'equalp") |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2305 (Assert-equalp |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2306 (string ?h ?i ?\ ?t ?h ?e ?r ?e) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2307 (vector ?h ?i ?\ ?t ?h ?e ?r ?e) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2308 "check string and vector with same contents #'equalp, no constants") |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2309 (Assert-equalp |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2310 [?h ?i ?\ ?t ?h ?e ?r ?e] |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2311 (string ?h ?i ?\ ?t ?h ?e ?r ?e) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2312 "check string and vector with same contents #'equalp, vector constant") |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2313 (Assert-equalp [0 1.0 0.0 0 1] |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2314 (bit-vector 0 1 0 0 1) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2315 "check vector and bit-vector with same contents #'equalp,\ |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2316 vector constant") |
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2317 (Assert (not (equalp [0 2 0.0 0 1] |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2318 (bit-vector 0 1 0 0 1))) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2319 "check vector and bit-vector with different contents not #'equalp,\ |
4792
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2320 vector constant") |
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2321 (Assert-equalp #*01001 |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2322 (vector 0 1.0 0.0 0 1) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2323 "check vector and bit-vector with same contents #'equalp,\ |
4792
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2324 bit-vector constant") |
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2325 (Assert-equalp ?\u00E9 Eacute-character |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2326 "checking characters are case-insensitive, one constant") |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2327 (Assert (not (equalp ?\u00E9 (aref (format "%c" ?a) 0))) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2328 "checking distinct characters are not equalp, one constant") |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2329 (Assert-equalp t (and) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2330 "checking symbols are correctly #'equalp") |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2331 (Assert (not (equalp t (or nil '#:t))) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2332 "checking distinct symbols with the same name are not #'equalp") |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2333 (Assert-equalp #s(char-table type generic data (?\u0080 "hi-there")) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2334 (let ((aragh (make-char-table 'generic))) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2335 (put-char-table ?\u0080 "hi-there" aragh) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2336 aragh) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2337 "checking #'equalp succeeds correctly, char-tables") |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2338 (Assert-equalp #s(char-table type generic data (?\u0080 "hi-there")) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2339 (let ((aragh (make-char-table 'generic))) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2340 (put-char-table ?\u0080 "HI-THERE" aragh) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2341 aragh) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2342 "checking #'equalp succeeds correctly, char-tables") |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2343 (Assert (not (equalp #s(char-table type generic data (?\u0080 "hi-there")) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2344 (let ((aragh (make-char-table 'generic))) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2345 (put-char-table ?\u0080 "hi there" aragh) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2346 aragh))) |
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5188
diff
changeset
|
2347 "checking #'equalp fails correctly, char-tables"))) |
4792
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2348 |
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2349 ;; 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
|
2350 ;; |
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2351 ;; 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
|
2352 ;; |
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2353 ;; 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
|
2354 ;; 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
|
2355 ;; 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
|
2356 ;; 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
|
2357 ;; 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
|
2358 ;; 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
|
2359 |
4795
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2360 (loop |
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2361 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
|
2362 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
|
2363 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
|
2364 do |
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2365 (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
|
2366 (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
|
2367 (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
|
2368 (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
|
2369 (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
|
2370 (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
|
2371 (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
|
2372 (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
|
2373 |
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2374 (loop |
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2375 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
|
2376 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
|
2377 (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
|
2378 |
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2379 ;; #'member, #'assoc tests. |
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2380 |
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2381 (when (featurep 'bignum) |
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2382 (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
|
2383 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
|
2384 (assoc*-list (loop |
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2385 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
|
2386 collect (cons elt (random)))) |
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2387 (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
|
2388 hashed-bignum) |
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2389 (macrolet |
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2390 ((1+most-positive-fixnum () |
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2391 (1+ most-positive-fixnum)) |
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2392 (1-most-negative-fixnum () |
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2393 (1- most-negative-fixnum)) |
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2394 (*-2-most-positive-fixnum () |
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2395 (* 2 most-positive-fixnum))) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2396 (Assert (eq |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2397 (member* (1+ most-positive-fixnum) member*-list) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2398 (member* (1+ most-positive-fixnum) member*-list :test #'eql)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2399 "checking #'member* correct if #'eql not explicitly specified") |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2400 (Assert (eq |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2401 (assoc* (1+ most-positive-fixnum) assoc*-list) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2402 (assoc* (1+ most-positive-fixnum) assoc*-list :test #'eql)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2403 "checking #'assoc* correct if #'eql not explicitly specified") |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2404 (Assert (eq |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2405 (rassoc* (1- most-negative-fixnum) assoc*-list) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2406 (rassoc* (1- most-negative-fixnum) assoc*-list :test #'eql)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2407 "checking #'rassoc* correct if #'eql not explicitly specified") |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2408 (Assert (eql (1+most-positive-fixnum) (1+ most-positive-fixnum)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2409 "checking #'eql handles a bignum literal properly.") |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2410 (Assert (eq |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2411 (member* (1+most-positive-fixnum) member*-list) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2412 (member* (1+ most-positive-fixnum) member*-list :test #'equal)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2413 "checking #'member* compiler macro correct with literal bignum") |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2414 (Assert (eq |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2415 (assoc* (1+most-positive-fixnum) assoc*-list) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2416 (assoc* (1+ most-positive-fixnum) assoc*-list :test #'equal)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2417 "checking #'assoc* compiler macro correct with literal bignum") |
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2418 (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
|
2419 (gensym) hashing) |
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2420 (Assert (eq |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2421 (gethash (* 2 most-positive-fixnum) hashing) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2422 (gethash hashed-bignum hashing)) |
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
5036
diff
changeset
|
2423 "checking hashing works correctly with #'eql tests and bignums")))) |
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2424 |
5241
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2425 ;; |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2426 (when (decode-char 'ucs #x0192) |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2427 (Check-Error |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2428 invalid-state |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2429 (let ((str "aaaaaaaaaaaaa") |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2430 (called 0) |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2431 modified) |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2432 (reduce #'+ str |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2433 :key #'(lambda (object) |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2434 (prog1 |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2435 object |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2436 (incf called) |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2437 (or modified |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2438 (and (> called 5) |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2439 (setq modified |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2440 (fill str (read #r"?\u0192"))))))))))) |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2441 |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2442 (Assert |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2443 (eql 55 |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2444 (let ((sequence '(1 2 3 4 5 6 7 8 9 10)) |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2445 (called 0) |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2446 modified) |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2447 (reduce #'+ |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2448 sequence |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2449 :key |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2450 #'(lambda (object) (prog1 |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2451 object |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2452 (incf called) |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2453 (and (eql called 5) |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2454 (setcdr (nthcdr 3 sequence) nil)) |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2455 (garbage-collect)))))) |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2456 "checking we can amputate lists without crashing #'reduce") |
d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2457 |
5244
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2458 (Assert (not (eq t (canonicalize-inst-list |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2459 `(((mswindows) . [string :data ,(make-string 20 0)]) |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2460 ((tty) . [string :data " "])) 'image t))) |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2461 "checking mswindows is always available as a specifier tag") |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2462 |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2463 (Assert (not (eq t (canonicalize-inst-list |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2464 `(((mswindows) . [nothing]) |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2465 ((tty) . [string :data " "])) |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2466 'image t))) |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2467 "checking the correct syntax for a nothing image specifier works") |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2468 |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2469 (Check-Error-Message invalid-argument "^Invalid specifier tag set" |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2470 (canonicalize-inst-list |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2471 `(((,(gensym)) . [nothing]) |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2472 ((tty) . [string :data " "])) |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2473 'image)) |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2474 |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2475 (Check-Error-Message invalid-argument "^Unrecognized keyword" |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2476 (canonicalize-inst-list |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2477 `(((mswindows) . [nothing :data "hi there"]) |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2478 ((tty) . [string :data " "])) 'image)) |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2479 |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2480 ;; If we combine both the specifier inst list problems, we get the |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2481 ;; unrecognized keyword error first, not the invalid specifier tag set |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2482 ;; error. This is a little unintuitive; the specifier tag set thing is |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2483 ;; processed first, and would seem to be more important. But anyone writing |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2484 ;; code needs to solve both problems, it's reasonable to ask them to do it |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2485 ;; in series rather than in parallel. |
04811a268716
Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec
Aidan Kehoe <kehoea@parhasard.net>
parents:
5243
diff
changeset
|
2486 |
5243
808131ba4a57
Print symbols with ratio-like names and the associated ratios distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2487 (when (featurep 'ratio) |
808131ba4a57
Print symbols with ratio-like names and the associated ratios distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2488 (Assert (not (eql '1/2 (read (prin1-to-string (intern "1/2"))))) |
808131ba4a57
Print symbols with ratio-like names and the associated ratios distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2489 "checking symbols with ratio-like names are printed distinctly") |
808131ba4a57
Print symbols with ratio-like names and the associated ratios distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2490 (Assert (not (eql '1/5 (read (prin1-to-string (intern "2/10"))))) |
808131ba4a57
Print symbols with ratio-like names and the associated ratios distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2491 "checking symbol named \"2/10\" not eql to ratio 1/5 on read")) |
808131ba4a57
Print symbols with ratio-like names and the associated ratios distinctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2492 |
5283
be436ac36ba4
Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5244
diff
changeset
|
2493 (let* ((count 0) |
be436ac36ba4
Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5244
diff
changeset
|
2494 (list (map-into (make-list 2048 nil) #'(lambda () (decf count)))) |
be436ac36ba4
Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5244
diff
changeset
|
2495 (expected (append list '(1)))) |
be436ac36ba4
Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5244
diff
changeset
|
2496 (Assert (equal expected (merge 'list list '(1) #'<)) |
be436ac36ba4
Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5244
diff
changeset
|
2497 "checking merge's circularity checks are sane")) |
be436ac36ba4
Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5244
diff
changeset
|
2498 |
5300
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2499 (flet ((list-nreverse (list) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2500 (do ((list1 list (cdr list1)) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2501 (list2 nil (prog1 list1 (setcdr list1 list2)))) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2502 ((atom list1) list2)))) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2503 (let* ((integers (loop for i from 0 to 6000 collect i)) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2504 (characters (mapcan #'(lambda (integer) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2505 (if (char-int-p integer) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2506 (list (int-char integer)))) integers)) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2507 (fourth-bit #'(lambda (integer) (ash (logand #x10 integer) -4))) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2508 (bits (mapcar fourth-bit integers)) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2509 (vector (vconcat integers)) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2510 (string (concat characters)) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2511 (bit-vector (bvconcat bits))) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2512 (Assert (equal (reverse vector) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2513 (vconcat (list-nreverse (copy-list integers))))) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2514 (Assert (eq vector (nreverse vector))) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2515 (Assert (equal vector (vconcat (list-nreverse (copy-list integers))))) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2516 (Assert (equal (reverse string) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2517 (concat (list-nreverse (copy-list characters))))) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2518 (Assert (eq string (nreverse string))) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2519 (Assert (equal string (concat (list-nreverse (copy-list characters))))) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2520 (Assert (eq bit-vector (nreverse bit-vector))) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2521 (Assert (equal (bvconcat (list-nreverse (copy-list bits))) bit-vector)) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2522 (Assert (not (equal bit-vector |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2523 (mapcar fourth-bit |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2524 (loop for i from 0 to 6000 collect i))))))) |
9f738305f80f
Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5299
diff
changeset
|
2525 |
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2526 (Check-Error wrong-type-argument (self-insert-command 'self-insert-command)) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2527 (Check-Error wrong-type-argument (make-list 'make-list 'make-list)) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2528 (Check-Error wrong-type-argument (make-vector 'make-vector 'make-vector)) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2529 (Check-Error wrong-type-argument (make-bit-vector 'make-bit-vector |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2530 'make-bit-vector)) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2531 (Check-Error wrong-type-argument (make-byte-code '(&rest ignore) "\xc0\x87" [4] |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2532 'ignore)) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2533 (Check-Error wrong-type-argument (make-string ?a ?a)) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2534 (Check-Error wrong-type-argument (nth-value 'nth-value (truncate pi e))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2535 (Check-Error wrong-type-argument (make-hash-table :test #'eql :size :size)) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2536 (Check-Error wrong-type-argument |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2537 (accept-process-output nil 'accept-process-output)) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2538 (Check-Error wrong-type-argument |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2539 (accept-process-output nil 2000 'accept-process-output)) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2540 (Check-Error wrong-type-argument |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2541 (self-insert-command 'self-insert-command)) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2542 (Check-Error wrong-type-argument (string-to-number "16" 'string-to-number)) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2543 (Check-Error wrong-type-argument (move-to-column 'move-to-column)) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2544 (stop-profiling) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2545 (Check-Error wrong-type-argument (start-profiling (float most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2546 (stop-profiling) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2547 (Check-Error wrong-type-argument |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2548 (fill '(1 2 3 4 5) 1 :start (float most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2549 (Check-Error wrong-type-argument |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2550 (fill [1 2 3 4 5] 1 :start (float most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2551 (Check-Error wrong-type-argument |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2552 (fill "1 2 3 4 5" ?1 :start (float most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2553 (Check-Error wrong-type-argument |
5323
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2554 (fill #*10101010 1 :start (float most-positive-fixnum))) |
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2555 (Check-Error wrong-type-argument |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2556 (fill '(1 2 3 4 5) 1 :end (float most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2557 (Check-Error wrong-type-argument |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2558 (fill [1 2 3 4 5] 1 :end (float most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2559 (Check-Error wrong-type-argument |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2560 (fill "1 2 3 4 5" ?1 :end (float most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2561 (Check-Error wrong-type-argument |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2562 (fill #*10101010 1 :end (float most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2563 (Check-Error wrong-type-argument |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2564 (reduce #'cons '(1 2 3 4 5) :start (float most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2565 (Check-Error wrong-type-argument |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2566 (reduce #'cons [1 2 3 4 5] :start (float most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2567 (Check-Error wrong-type-argument |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2568 (reduce #'cons "1 2 3 4 5" :start (float most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2569 (Check-Error wrong-type-argument |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2570 (reduce #'cons #*10101010 :start (float most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2571 (Check-Error wrong-type-argument |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2572 (reduce #'cons '(1 2 3 4 5) :end (float most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2573 (Check-Error wrong-type-argument |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2574 (reduce #'cons [1 2 3 4 5] :end (float most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2575 (Check-Error wrong-type-argument |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2576 (reduce #'cons "1 2 3 4 5" :end (float most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2577 (Check-Error wrong-type-argument |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2578 (reduce #'cons #*10101010 :end (float most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2579 |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2580 (when (featurep 'bignum) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2581 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2582 (self-insert-command (* 2 most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2583 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2584 (make-list (* 3 most-positive-fixnum) 'make-list)) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2585 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2586 (make-vector (* 4 most-positive-fixnum) 'make-vector)) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2587 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2588 (make-bit-vector (+ 2 most-positive-fixnum) 'make-bit-vector)) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2589 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2590 (make-byte-code '(&rest ignore) "\xc0\x87" [4] |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2591 (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2592 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2593 (make-byte-code '(&rest ignore) "\xc0\x87" [4] |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2594 #x10000)) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2595 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2596 (make-string (* 4 most-positive-fixnum) ?a)) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2597 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2598 (nth-value most-positive-fixnum (truncate pi e))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2599 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2600 (make-hash-table :test #'equalp :size (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2601 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2602 (accept-process-output nil 4294967)) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2603 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2604 (accept-process-output nil 10 (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2605 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2606 (self-insert-command (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2607 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2608 (string-to-number "16" (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2609 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2610 (recent-keys (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2611 (when (featurep 'xbm) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2612 (Check-Error-Message |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2613 invalid-argument |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2614 "^data is too short for width and height" |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2615 (set-face-background-pixmap |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2616 'left-margin |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2617 `[xbm :data (20 ,(* 2 most-positive-fixnum) "random-text")]))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2618 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2619 (move-to-column (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2620 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2621 (move-to-column (1- most-negative-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2622 (stop-profiling) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2623 (when (< most-positive-fixnum (lsh 1 32)) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2624 ;; We only support machines with integers of 32 bits or more. If |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2625 ;; most-positive-fixnum is less than 2^32, we're on a 32-bit machine, |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2626 ;; and it's appropriate to test start-profiling with a bignum. |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2627 (Assert (eq nil (start-profiling (* most-positive-fixnum 2))))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2628 (stop-profiling) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2629 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2630 (fill '(1 2 3 4 5) 1 :start (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2631 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2632 (fill [1 2 3 4 5] 1 :start (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2633 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2634 (fill "1 2 3 4 5" ?1 :start (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2635 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2636 (fill #*10101010 1 :start (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2637 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2638 (fill '(1 2 3 4 5) 1 :end (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2639 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2640 (fill [1 2 3 4 5] 1 :end (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2641 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2642 (fill "1 2 3 4 5" ?1 :end (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2643 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2644 (fill #*10101010 1 :end (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2645 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2646 (reduce #'cons '(1 2 3 4 5) :start (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2647 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2648 (reduce #'cons [1 2 3 4 5] :start (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2649 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2650 (reduce #'cons "1 2 3 4 5" :start (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2651 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2652 (reduce #'cons #*10101010 :start (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2653 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2654 (reduce #'cons '(1 2 3 4 5) :end (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2655 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2656 (reduce #'cons [1 2 3 4 5] :end (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2657 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2658 (reduce #'cons "1 2 3 4 5" :end (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2659 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2660 (reduce #'cons #*10101010 :end (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2661 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2662 (replace '(1 2 3 4 5) [5 4 3 2 1] |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2663 :start1 (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2664 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2665 (replace '(1 2 3 4 5) [5 4 3 2 1] |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2666 :start2 (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2667 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2668 (replace '(1 2 3 4 5) [5 4 3 2 1] |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2669 :end1 (1+ most-positive-fixnum))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2670 (Check-Error args-out-of-range |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2671 (replace '(1 2 3 4 5) [5 4 3 2 1] |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2672 :end2 (1+ most-positive-fixnum)))) |
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
2673 |
5323
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2674 (symbol-macrolet |
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2675 ((list-length 2048) (vector-length 512) (string-length (* 8192 2))) |
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2676 (let ((list |
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2677 ;; CIRCULAR_LIST_SUSPICION_LENGTH is 1024, it's helpful if this list |
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2678 ;; is longer than that. |
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2679 (make-list list-length 'make-list)) |
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2680 (vector (make-vector vector-length 'make-vector)) |
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2681 (bit-vector (make-bit-vector vector-length 1)) |
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2682 (string (make-string string-length |
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2683 (or (decode-char 'ucs #x20ac) ?\xFF))) |
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2684 (item 'cons)) |
5347
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2685 (macrolet |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2686 ((construct-item-sequence-checks (&rest functions) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2687 (cons |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2688 'progn |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2689 (mapcan |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2690 #'(lambda (function) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2691 `((Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2692 (,function item list |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2693 :start (1+ list-length) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2694 :end (1+ list-length))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2695 (Check-Error wrong-type-argument |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2696 (,function item list :start -1 |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2697 :end list-length)) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2698 (Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2699 (,function item list :end (* 2 list-length))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2700 (Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2701 (,function item vector |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2702 :start (1+ vector-length) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2703 :end (1+ vector-length))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2704 (Check-Error wrong-type-argument |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2705 (,function item vector :start -1)) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2706 (Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2707 (,function item vector |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2708 :end (* 2 vector-length))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2709 (Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2710 (,function item bit-vector |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2711 :start (1+ vector-length) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2712 :end (1+ vector-length))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2713 (Check-Error wrong-type-argument |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2714 (,function item bit-vector :start -1)) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2715 (Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2716 (,function item bit-vector |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2717 :end (* 2 vector-length))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2718 (Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2719 (,function item string |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2720 :start (1+ string-length) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2721 :end (1+ string-length))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2722 (Check-Error wrong-type-argument |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2723 (,function item string :start -1)) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2724 (Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2725 (,function item string |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2726 :end (* 2 string-length))))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2727 functions))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2728 (construct-one-sequence-checks (&rest functions) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2729 (cons |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2730 'progn |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2731 (mapcan |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2732 #'(lambda (function) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2733 `((Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2734 (,function (copy-sequence list) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2735 :start (1+ list-length) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2736 :end (1+ list-length))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2737 (Check-Error wrong-type-argument |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2738 (,function (copy-sequence list) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2739 :start -1 :end list-length)) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2740 (Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2741 (,function (copy-sequence list) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2742 :end (* 2 list-length))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2743 (Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2744 (,function (copy-sequence vector) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2745 :start (1+ vector-length) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2746 :end (1+ vector-length))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2747 (Check-Error wrong-type-argument |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2748 (,function (copy-sequence vector) :start -1)) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2749 (Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2750 (,function (copy-sequence vector) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2751 :end (* 2 vector-length))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2752 (Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2753 (,function (copy-sequence bit-vector) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2754 :start (1+ vector-length) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2755 :end (1+ vector-length))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2756 (Check-Error wrong-type-argument |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2757 (,function (copy-sequence bit-vector) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2758 :start -1)) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2759 (Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2760 (,function (copy-sequence bit-vector) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2761 :end (* 2 vector-length))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2762 (Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2763 (,function (copy-sequence string) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2764 :start (1+ string-length) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2765 :end (1+ string-length))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2766 (Check-Error wrong-type-argument |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2767 (,function (copy-sequence string) :start -1)) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2768 (Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2769 (,function (copy-sequence string) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2770 :end (* 2 string-length))))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2771 functions))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2772 (construct-two-sequence-checks (&rest functions) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2773 (cons |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2774 'progn |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2775 (mapcan |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2776 #'(lambda (function) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2777 `((Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2778 (,function (copy-sequence list) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2779 (copy-sequence list) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2780 :start1 (1+ list-length) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2781 :end1 (1+ list-length))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2782 (Check-Error wrong-type-argument |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2783 (,function (copy-sequence list) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2784 (copy-sequence list) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2785 :start1 -1 :end1 list-length)) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2786 (Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2787 (,function (copy-sequence list) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2788 (copy-sequence list) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2789 :end1 (* 2 list-length))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2790 (Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2791 (,function (copy-sequence vector) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2792 (copy-sequence vector) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2793 :start1 (1+ vector-length) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2794 :end1 (1+ vector-length))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2795 (Check-Error wrong-type-argument |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2796 (,function |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2797 (copy-sequence vector) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2798 (copy-sequence vector) :start1 -1)) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2799 (Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2800 (,function (copy-sequence vector) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2801 (copy-sequence vector) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2802 :end1 (* 2 vector-length))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2803 (Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2804 (,function (copy-sequence bit-vector) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2805 (copy-sequence bit-vector) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2806 :start1 (1+ vector-length) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2807 :end1 (1+ vector-length))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2808 (Check-Error wrong-type-argument |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2809 (,function (copy-sequence bit-vector) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2810 (copy-sequence bit-vector) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2811 :start1 -1)) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2812 (Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2813 (,function (copy-sequence bit-vector) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2814 (copy-sequence bit-vector) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2815 :end1 (* 2 vector-length))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2816 (Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2817 (,function (copy-sequence string) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2818 (copy-sequence string) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2819 :start1 (1+ string-length) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2820 :end1 (1+ string-length))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2821 (Check-Error wrong-type-argument |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2822 (,function (copy-sequence string) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2823 (copy-sequence string) :start1 -1)) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2824 (Check-Error args-out-of-range |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2825 (,function (copy-sequence string) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2826 (copy-sequence string) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2827 :end1 (* 2 string-length))))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2828 functions)))) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2829 (construct-item-sequence-checks count position find delete* remove* |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2830 reduce) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2831 (construct-one-sequence-checks delete-duplicates remove-duplicates) |
fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5346
diff
changeset
|
2832 (construct-two-sequence-checks replace mismatch search)))) |
5323
f87bb35a6b94
Test sanity-checking of :start, :end keyword arguments when appropriate.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2833 |
5336
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2834 (let* ((list (list 1 2 3 4 5 6 7 120 'hi-there '#:everyone)) |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2835 (vector (map 'vector #'identity list)) |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2836 (bit-vector (map 'bit-vector |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2837 #'(lambda (object) (if (fixnump object) 1 0)) list)) |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2838 (string (map 'string |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2839 #'(lambda (object) (or (and (fixnump object) |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2840 (int-char object)) |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2841 (decode-char 'ucs #x20ac))) list)) |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2842 (gensym (gensym))) |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2843 (Assert (null (find 'not-in-it list))) |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2844 (Assert (null (find 'not-in-it vector))) |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2845 (Assert (null (find 'not-in-it bit-vector))) |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2846 (Assert (null (find 'not-in-it string))) |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2847 (loop |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2848 for elt being each element in vector using (index position) |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2849 do |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2850 (Assert (eq elt (find elt list))) |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2851 (Assert (eq (elt list position) (find elt vector)))) |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2852 (Assert (eq gensym (find 'not-in-it list :default gensym))) |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2853 (Assert (eq gensym (find 'not-in-it vector :default gensym))) |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2854 (Assert (eq gensym (find 'not-in-it bit-vector :default gensym))) |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2855 (Assert (eq gensym (find 'not-in-it string :default gensym))) |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2856 (Assert (eq 'hi-there (find 'hi-there list))) |
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2857 ;; Different uninterned symbols with the same name. |
5339
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2858 (Assert (not (eq '#1=#:everyone (find '#1# list)))) |
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2859 |
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2860 ;; Test concatenate. |
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2861 (Assert (equal list (concatenate 'list vector))) |
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2862 (Assert (equal list (concatenate 'list (subseq vector 0 4) |
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2863 (subseq list 4)))) |
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2864 (Assert (equal vector (concatenate 'vector list))) |
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2865 (Assert (equal vector (concatenate `(vector * ,(length vector)) list))) |
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2866 (Assert (equal string (concatenate `(vector character ,(length string)) |
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2867 (append string nil)))) |
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2868 (Assert (equal bit-vector (concatenate 'bit-vector (subseq bit-vector 0 4) |
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2869 (append (subseq bit-vector 4) nil)))) |
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2870 (Assert (equal bit-vector (concatenate `(vector bit ,(length bit-vector)) |
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2871 (subseq bit-vector 0 4) |
ba62563ec7c7
Accept more complex TYPEs in #'concatenate, cl-extra.el
Aidan Kehoe <kehoea@parhasard.net>
parents:
5336
diff
changeset
|
2872 (append (subseq bit-vector 4) nil))))) |
5336
287499ff4c5f
Pass in the DEFAULT argument to position() as documented, #'find.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5329
diff
changeset
|
2873 |
5353
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2874 ;;----------------------------------------------------- |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2875 ;; Test `block', `return-from' |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2876 ;;----------------------------------------------------- |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2877 (Assert (eql 1 (block outer |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2878 (flet ((outtahere (n) (return-from outer n))) |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2879 (block outer (outtahere 1))) |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2880 2)) |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2881 "checking `block' and `return-from' are lexically scoped correctly") |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2882 |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2883 ;; Other tests are available in Paul Dietz' test suite, and pass. The above, |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2884 ;; which we used to fail, is based on a test in the Hyperspec. We still |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2885 ;; behave incorrectly when compiled for the contorted-example function of |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2886 ;; CLTL2, whence the following test: |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2887 |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2888 (flet ((needs-lexical-context (first second third) |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2889 (if (eql 0 first) |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2890 (funcall second) |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2891 (block awkward |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2892 (+ 5 (needs-lexical-context |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2893 (1- first) |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2894 third |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2895 #'(lambda () (return-from awkward 0))) |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2896 first))))) |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2897 (if (compiled-function-p (symbol-function 'needs-lexical-context)) |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2898 (Known-Bug-Expect-Failure |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2899 (Assert (eql 0 (needs-lexical-context 2 nil nil)) |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2900 "the function special operator doesn't create a lexical context.")) |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2901 (Assert (eql 0 (needs-lexical-context 2 nil nil))))) |
38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5347
diff
changeset
|
2902 |
4732
2491a837112c
Fix typo in test of equalp and add more tests.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4728
diff
changeset
|
2903 ;;; end of lisp-tests.el |