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
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4 ;; Author: Martin Buchholz <martin@xemacs.org>
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5 ;; Maintainer: Martin Buchholz <martin@xemacs.org>
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6 ;; Created: 1998
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7 ;; Keywords: tests
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
8
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
9 ;; This file is part of XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
10
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
11 ;; XEmacs is free software; you can redistribute it and/or modify it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
12 ;; under the terms of the GNU General Public License as published by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
13 ;; the Free Software Foundation; either version 2, or (at your option)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
14 ;; any later version.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
15
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
16 ;; XEmacs is distributed in the hope that it will be useful, but
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
19 ;; General Public License for more details.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
20
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
21 ;; You should have received a copy of the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
22 ;; along with XEmacs; see the file COPYING. If not, write to the Free
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
24 ;; 02111-1307, USA.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
25
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
26 ;;; Synched up with: Not in FSF.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
27
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
28 ;;; Commentary:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
29
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
30 ;;; Test basic Lisp engine functionality
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
31 ;;; See test-harness.el for instructions on how to run these tests.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
32
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
33 (eval-when-compile
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
34 (condition-case nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
35 (require 'test-harness)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
36 (file-error
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
37 (push "." load-path)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
38 (when (and (boundp 'load-file-name) (stringp load-file-name))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
39 (push (file-name-directory load-file-name) load-path))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
40 (require 'test-harness))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
41
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
42 (Check-Error wrong-number-of-arguments (setq setq-test-foo))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
43 (Check-Error wrong-number-of-arguments (setq setq-test-foo 1 setq-test-bar))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
44 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
52
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
53 (macrolet ((test-setq (expected-result &rest body)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
54 `(progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
59 (test-setq nil (setq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
60 (test-setq nil (setq-default))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
61 (test-setq 42 (setq test-setq-var 42))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
62 (test-setq 42 (setq-default test-setq-var 42))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
63 (test-setq 42 (setq test-setq-bar 99 test-setq-var 42))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
64 (test-setq 42 (setq-default test-setq-bar 99 test-setq-var 42))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
65 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
66
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
67 (let ((my-vector [1 2 3 4])
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
68 (my-bit-vector (bit-vector 1 0 1 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
69 (my-string "1234")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
70 (my-list '(1 2 3 4)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
71
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
74
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
75 (dolist (sequence (list my-vector my-bit-vector my-string my-list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
78
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
79 (dolist (array (list my-vector my-bit-vector my-string))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
80 (Assert (arrayp array)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
86
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
87 (fillarray my-vector 5)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
88 (fillarray my-bit-vector 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
89 (fillarray my-string ?5)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
90
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
101
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
105 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
106
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
107 (defun make-circular-list (length)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
108 "Create evil emacs-crashing circular list of length LENGTH"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
109 (let ((circular-list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
110 (make-list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
111 length
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
112 'you-are-trapped-in-a-twisty-maze-of-cons-cells-all-alike)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
113 (setcdr (last circular-list) circular-list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
114 circular-list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
115
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
116 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
117 ;; Test `nconc'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
118 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
119 (defun make-list-012 () (list 0 1 2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
120
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
121 (Check-Error wrong-type-argument (nconc 'foo nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
122
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
123 (dolist (length '(1 2 3 4 1000 2000))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
124 (Check-Error circular-list (nconc (make-circular-list length) 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
125 (Check-Error circular-list (nconc '(1 . 2) (make-circular-list length) 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
126 (Check-Error circular-list (nconc '(1 . 2) '(3 . 4) (make-circular-list length) 'foo)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
140
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
144
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
145 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
146 ;; Test `last'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
147 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
148 (Check-Error wrong-type-argument (last 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
149 (Check-Error wrong-number-of-arguments (last))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
150 (Check-Error wrong-number-of-arguments (last '(1 2) 1 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
151 (Check-Error circular-list (last (make-circular-list 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
152 (Check-Error circular-list (last (make-circular-list 2000)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
163 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
164
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
165 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
166 ;; Test `butlast' and `nbutlast'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
167 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
168 (Check-Error wrong-type-argument (butlast 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
169 (Check-Error wrong-type-argument (nbutlast 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
170 (Check-Error wrong-number-of-arguments (butlast))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
171 (Check-Error wrong-number-of-arguments (nbutlast))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
172 (Check-Error wrong-number-of-arguments (butlast '(1 2) 1 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
173 (Check-Error wrong-number-of-arguments (nbutlast '(1 2) 1 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
174 (Check-Error circular-list (butlast (make-circular-list 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
175 (Check-Error circular-list (nbutlast (make-circular-list 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
176 (Check-Error circular-list (butlast (make-circular-list 2000)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
177 (Check-Error circular-list (nbutlast (make-circular-list 2000)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
178
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
179 (let* ((x (list 0 1 2 3))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
180 (y (butlast x))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
186
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
187 (let* ((x (list 0 1 2 3 4))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
188 (y (butlast x 2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
194
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
195 (let* ((x (list 0 1 2 3))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
196 (y (butlast x 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
226 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
227 ;; Test `copy-list'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
228 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
229 (Check-Error wrong-type-argument (copy-list 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
230 (Check-Error wrong-number-of-arguments (copy-list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
231 (Check-Error wrong-number-of-arguments (copy-list '(1 2) 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
232 (Check-Error circular-list (copy-list (make-circular-list 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
235 (dolist (x '((1) (1 2) (1 2 3) (1 2 . 3)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
236 (let ((y (copy-list x)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
237 (Assert (and (equal x y) (not (eq x y))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
238
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
292 ;; Arithmetic operations
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
293 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
294
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
303 (if (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
304 (progn
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
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
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
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
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
310 (Assert (zerop (+ (* 3 most-negative-fixnum) (* 3 most-positive-fixnum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
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
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
314
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
315 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
316 (let ((threefourths (read "3/4"))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
317 (threehalfs (read "3/2"))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
318 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
319 (bigneg (div (+ most-positive-fixnum 2) most-negative-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
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
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
323 (Assert (zerop (+ bigpos bigneg)))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
324
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
325 ;; Test `-'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
349
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
350 (if (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
351 (progn
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
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
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
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
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
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
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
362
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
363 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
364 (let ((threefourths (read "3/4"))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
365 (threehalfs (read "3/2"))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
366 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
367 (bigneg (div most-positive-fixnum most-negative-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
372
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
373 ;; Test `/'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
374
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
375 ;; Test division by zero errors
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
376 (dolist (zero '(0 0.0 ?\0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
377 (Check-Error arith-error (/ zero))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
378 (dolist (n1 `(42 42.0 ?\042 ,(Int-to-Marker 42)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
379 (Check-Error arith-error (/ n1 zero))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
380 (dolist (n2 `(3 3.0 ?\03 ,(Int-to-Marker 3)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
381 (Check-Error arith-error (/ n1 n2 zero)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
382
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
383 ;; Other tests for `/'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
384 (Check-Error wrong-number-of-arguments (/))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
388
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
389 (dolist (six '(6 6.0 ?\06))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
390 (dolist (two '(2 2.0 ?\02))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
393
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
398
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
399 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
400 (let* ((million 1000000)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
401 (billion (* million 1000)) ;; American, not British, billion
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
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
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
409
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
410 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
411 (let ((half (div 1 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
412 (fivefourths (div 5 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
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
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
420
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
423
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
426
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
429
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
430 (dolist (six '(6 6.0 ?\06))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
431 (dolist (two '(2 2.0 ?\02))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
434
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
435 (dolist (three '(3 3.0 ?\03))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
440
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
441 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
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
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
445 (Assert (/= (* -1 most-negative-fixnum) most-negative-fixnum))))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
446
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
447 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
448 (let ((half (div 1 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
449 (fivefourths (div 5 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
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
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
453
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
456
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
459
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
462
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
463 (dolist (five '(5 5.0 ?\05))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
464 (dolist (two '(2 2.0 ?\02))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
468
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
469 ;; Test `max', `min'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
484
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
485 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
486 (let ((big (1+ most-positive-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
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
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
490
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
491 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
492 (let* ((big (1+ most-positive-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
493 (small (1- most-negative-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
494 (bigr (div (* 5 (1+ most-positive-fixnum)) 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
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
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
498
446
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
499 ;; The byte compiler has special handling for these constructs:
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
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
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
530
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
531
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
532 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
533 ;; Logical bit-twiddling operations
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
538
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
539 (Check-Error wrong-type-argument (logxor 3.0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
540 (Check-Error wrong-type-argument (logior 3.0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
541 (Check-Error wrong-type-argument (logand 3.0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
542
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
550
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
551 (dolist (one `(1 ?\01 ,(Int-to-Marker 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
560
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
561 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
562 ;; Test `%', mod
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
563 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
564 (Check-Error wrong-number-of-arguments (%))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
565 (Check-Error wrong-number-of-arguments (% 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
566 (Check-Error wrong-number-of-arguments (% 1 2 3))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
567
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
568 (Check-Error wrong-number-of-arguments (mod))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
569 (Check-Error wrong-number-of-arguments (mod 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
570 (Check-Error wrong-number-of-arguments (mod 1 2 3))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
571
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
572 (Check-Error wrong-type-argument (% 10.0 2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
573 (Check-Error wrong-type-argument (% 10 2.0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
580 (test1 most-negative-fixnum)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
581 (if (featurep 'bignum)
2075
c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james]
james
parents: 2056
diff changeset
582 (progn
c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james]
james
parents: 2056
diff changeset
583 (test2 most-negative-fixnum)
c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james]
james
parents: 2056
diff changeset
584 (test4 most-negative-fixnum))
c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james]
james
parents: 2056
diff changeset
585 (test3 most-negative-fixnum)
c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james]
james
parents: 2056
diff changeset
586 (test5 most-negative-fixnum))
2056
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
587 (test1 most-positive-fixnum)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
588 (test2 most-positive-fixnum)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
589 (test4 most-positive-fixnum)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
590 (dotimes (j 30)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
591 (let ((x (random)))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
592 (if (eq x most-negative-fixnum) (setq x (1+ x)))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
593 (if (eq x most-positive-fixnum) (setq x (1- x)))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
594 (test1 x)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
595 (test2 x)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
596 (test4 x))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
597
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
598 (macrolet
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
599 ((division-test (seven)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
649
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
650 (division-test 7)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
651 (division-test ?\07)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
652 (division-test (Int-to-Marker 7)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
653
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
654 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
655 (let ((big (+ (* 7 most-positive-fixnum 6)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
656 (negbig (- (* 7 most-negative-fixnum 6))))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
657 (= (% big (1+ most-positive-fixnum)) most-positive-fixnum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
658 (= (% negbig (1- most-negative-fixnum)) most-negative-fixnum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
659 (= (mod big (1+ most-positive-fixnum)) most-positive-fixnum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
660 (= (mod negbig (1- most-negative-fixnum)) most-negative-fixnum)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
661
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
662 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
663 ;; Arithmetic comparison operations
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
664 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
665 (Check-Error wrong-number-of-arguments (=))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
666 (Check-Error wrong-number-of-arguments (<))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
667 (Check-Error wrong-number-of-arguments (>))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
668 (Check-Error wrong-number-of-arguments (<=))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
669 (Check-Error wrong-number-of-arguments (>=))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
670 (Check-Error wrong-number-of-arguments (/=))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
671
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
672 ;; One argument always yields t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
680 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
681
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
682 ;; Type checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
683 (Check-Error wrong-type-argument (= 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
684 (Check-Error wrong-type-argument (<= 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
685 (Check-Error wrong-type-argument (>= 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
686 (Check-Error wrong-type-argument (< 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
687 (Check-Error wrong-type-argument (> 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
688 (Check-Error wrong-type-argument (/= 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
689
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
690 ;; Meat
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
691 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
692 (dolist (two '(2 2.0 ?\02))
2056
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
693 (Assert (< one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
694 (Assert (<= one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
695 (Assert (<= two two) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
696 (Assert (> two one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
697 (Assert (>= two one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
698 (Assert (>= two two) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
699 (Assert (/= one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
700 (Assert (not (/= two two)) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
701 (Assert (not (< one one)) one)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
702 (Assert (not (> one one)) one)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
703 (Assert (<= one one two two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
704 (Assert (not (< one one two two)) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
705 (Assert (>= two two one one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
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
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
708 (Assert (not (= one one one two)) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
709 (Assert (not (/= one two one)) (list one two))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
710 ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
711
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
712 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
713 (dolist (two '(2 2.0 ?\02))
2056
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
714 (Assert (< one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
715 (Assert (<= one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
716 (Assert (<= two two) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
717 (Assert (> two one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
718 (Assert (>= two one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
719 (Assert (>= two two) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
720 (Assert (/= one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
721 (Assert (not (/= two two)) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
722 (Assert (not (< one one)) one)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
723 (Assert (not (> one one)) one)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
724 (Assert (<= one one two two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
725 (Assert (not (< one one two two)) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
726 (Assert (>= two two one one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
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
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
729 (Assert (not (= one one one two)) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james]
james
parents: 1983
diff changeset
730 (Assert (not (/= one two one)) (list one two))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
731 ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
732
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
733 ;; ad-hoc
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
734 (Assert (< 1 2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
735 (Assert (< 1 2 3 4 5 6))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
736 (Assert (not (< 1 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
737 (Assert (not (< 2 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
738
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
739
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
740 (Assert (not (< 1 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
741 (Assert (< 1 2 3 4 5 6))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
742 (Assert (<= 1 2 3 4 5 6))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
743 (Assert (<= 1 2 3 4 5 6 6))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
744 (Assert (not (< 1 2 3 4 5 6 6)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
745 (Assert (<= 1 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
746
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
750
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
751 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
752 (let ((big1 (1+ most-positive-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
753 (big2 (* 10 most-positive-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
754 (small1 (1- most-negative-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
755 (small2 (* 10 most-negative-fixnum)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
756 (Assert (< small2 small1 most-negative-fixnum most-positive-fixnum big1
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
757 big2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
758 (Assert (<= small2 small1 most-negative-fixnum most-positive-fixnum big1
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
759 big2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
760 (Assert (> big2 big1 most-positive-fixnum most-negative-fixnum small1
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
761 small2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
762 (Assert (>= big2 big1 most-positive-fixnum most-negative-fixnum small1
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
763 small2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
764 (Assert (/= small2 small1 most-negative-fixnum most-positive-fixnum big1
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
765 big2))))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
766
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
767 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
768 (let ((big1 (div (* 10 most-positive-fixnum) 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
769 (big2 (div (* 5 most-positive-fixnum) 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
770 (big3 (div (* 7 most-positive-fixnum) 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
771 (small1 (div (* 10 most-negative-fixnum) 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
772 (small2 (div (* 5 most-negative-fixnum) 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
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
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
776 (Assert (< small3 small1 most-negative-fixnum most-positive-fixnum big1
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
777 big3))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
778 (Assert (<= small3 small2 small1 most-negative-fixnum most-positive-fixnum
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
779 big1 big2 big3))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
780 (Assert (> big3 big1 most-positive-fixnum most-negative-fixnum small1
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
781 small3))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
782 (Assert (>= big3 big2 big1 most-positive-fixnum most-negative-fixnum
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
783 small1 small2 small3))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
784 (Assert (/= big3 big1 most-positive-fixnum most-negative-fixnum small1
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
785 small3))))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
786
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
787 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
788 ;; testing list-walker functions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
789 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
790 (macrolet
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
791 ((test-fun
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
792 (fun)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
793 `(progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
794 (Check-Error wrong-number-of-arguments (,fun))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
797 ,@(loop for n in '(1 2 2000)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
798 collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
799 (test-funs (&rest funs) `(progn ,@(loop for fun in funs collect `(test-fun ,fun)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
811
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
837
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
863
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
864 (flet ((a () (list '(1 . 2) 3 '(4 . 5))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
865 (Assert (let* ((x (a)) (y (remassoc 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
866 (Assert (let* ((x (a)) (y (remassq 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
867 (Assert (let* ((x (a)) (y (remrassoc 1 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
868 (Assert (let* ((x (a)) (y (remrassq 1 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
869
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
870 (Assert (let* ((x (a)) (y (remassoc 2 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
871 (Assert (let* ((x (a)) (y (remassq 2 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
872 (Assert (let* ((x (a)) (y (remrassoc 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
873 (Assert (let* ((x (a)) (y (remrassq 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
874
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
875 (Assert (let* ((x (a)) (y (remassoc 3 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
876 (Assert (let* ((x (a)) (y (remassq 3 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
877 (Assert (let* ((x (a)) (y (remrassoc 3 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
878 (Assert (let* ((x (a)) (y (remrassq 3 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
879
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
880 (Assert (let* ((x (a)) (y (remassoc 4 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
881 (Assert (let* ((x (a)) (y (remassq 4 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
882 (Assert (let* ((x (a)) (y (remrassoc 4 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
883 (Assert (let* ((x (a)) (y (remrassq 4 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
884
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
885 (Assert (let* ((x (a)) (y (remassoc 5 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
886 (Assert (let* ((x (a)) (y (remassq 5 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
887 (Assert (let* ((x (a)) (y (remrassoc 5 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
888 (Assert (let* ((x (a)) (y (remrassq 5 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
889
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
890 (Assert (let* ((x (a)) (y (remassoc 6 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
891 (Assert (let* ((x (a)) (y (remassq 6 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
892 (Assert (let* ((x (a)) (y (remrassoc 6 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
893 (Assert (let* ((x (a)) (y (remrassq 6 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
894
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
895 (Assert (let* ((x (a)) (y (delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
896 (Assert (let* ((x (a)) (y (delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
897 (Assert (let* ((x (a)) (y (old-delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
898 (Assert (let* ((x (a)) (y (old-delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
899
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
900 (Assert (let* ((x (a)) (y (delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
901 (Assert (let* ((x (a)) (y (delq '(1 . 2) x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
902 (Assert (let* ((x (a)) (y (old-delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
903 (Assert (let* ((x (a)) (y (old-delq '(1 . 2) x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
904 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
905
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
906
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
907
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
908 (flet ((a () (list '("1" . "2") "3" '("4" . "5"))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
909 (Assert (let* ((x (a)) (y (remassoc "1" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5"))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
910 (Assert (let* ((x (a)) (y (remassq "1" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
911 (Assert (let* ((x (a)) (y (remrassoc "1" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
912 (Assert (let* ((x (a)) (y (remrassq "1" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
913
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
914 (Assert (let* ((x (a)) (y (remassoc "2" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
915 (Assert (let* ((x (a)) (y (remassq "2" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
916 (Assert (let* ((x (a)) (y (remrassoc "2" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5"))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
917 (Assert (let* ((x (a)) (y (remrassq "2" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
918
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
919 (Assert (let* ((x (a)) (y (remassoc "3" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
920 (Assert (let* ((x (a)) (y (remassq "3" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
921 (Assert (let* ((x (a)) (y (remrassoc "3" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
922 (Assert (let* ((x (a)) (y (remrassq "3" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
923
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
924 (Assert (let* ((x (a)) (y (remassoc "4" x))) (and (eq x y) (equal y '(("1" . "2") "3")))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
925 (Assert (let* ((x (a)) (y (remassq "4" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
926 (Assert (let* ((x (a)) (y (remrassoc "4" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
927 (Assert (let* ((x (a)) (y (remrassq "4" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
928
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
929 (Assert (let* ((x (a)) (y (remassoc "5" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
930 (Assert (let* ((x (a)) (y (remassq "5" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
931 (Assert (let* ((x (a)) (y (remrassoc "5" x))) (and (eq x y) (equal y '(("1" . "2") "3")))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
932 (Assert (let* ((x (a)) (y (remrassq "5" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
933
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
934 (Assert (let* ((x (a)) (y (remassoc "6" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
935 (Assert (let* ((x (a)) (y (remassq "6" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
936 (Assert (let* ((x (a)) (y (remrassoc "6" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
937 (Assert (let* ((x (a)) (y (remrassq "6" x))) (and (eq x y) (equal y (a))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
938
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
939 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
940 ;; function-max-args, function-min-args
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
941 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
942 (defmacro check-function-argcounts (fun min max)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
946
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
947 (check-function-argcounts 'prog1 1 nil) ; special form
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
948 (check-function-argcounts 'command-execute 1 3) ; normal subr
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
949 (check-function-argcounts 'funcall 1 nil) ; `MANY' subr
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
950 (check-function-argcounts 'garbage-collect 0 0) ; no args subr
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
951
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
952 ;; Test interpreted and compiled functions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
953 (loop for (arglist min max) in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
954 '(((arg1 arg2 &rest args) 2 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
955 ((arg1 arg2 &optional arg3 arg4) 2 4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
956 ((arg1 arg2 &optional arg3 arg4 &rest args) 2 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
957 (() 0 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
958 do
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
959 (eval
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
960 `(progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
961 (defun test-fun ,arglist nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
962 (check-function-argcounts '(lambda ,arglist nil) ,min ,max)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
963 (check-function-argcounts (byte-compile '(lambda ,arglist nil)) ,min ,max))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
979 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
980 ;; Detection of cyclic variable indirection loops
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
981 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
982 (fset 'test-sym1 'test-sym1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
983 (Check-Error cyclic-function-indirection (test-sym1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
984
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
985 (fset 'test-sym1 'test-sym2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
986 (fset 'test-sym2 'test-sym1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
987 (Check-Error cyclic-function-indirection (test-sym1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
988 (fmakunbound 'test-sym1) ; else macroexpand-internal infloops!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
989 (fmakunbound 'test-sym2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
990
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
991 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
992 ;; Test `type-of'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1001
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1002 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1003 ;; Test mapping functions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1004 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1011
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1012 (let ((z 0) (list (make-list 1000 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1015
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1021
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1025
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1026 ;; The following 2 functions used to crash XEmacs via mapcar1().
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1027 ;; We don't test the actual values of the mapcar, since they're undefined.
446
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
1028 (Assert
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1029 (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3))))
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1030 (mapcar
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1031 (lambda (y)
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1032 "Devious evil mapping function"
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1033 (when (eq (car y) 2) ; go out onto a limb
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1034 (setcdr x nil) ; cut it off behind us
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1035 (garbage-collect)) ; are we riding a magic broomstick?
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1036 (car y)) ; sorry, hard landing
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1037 x)))
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1038
446
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
1039 (Assert
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1040 (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3))))
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1041 (mapcar
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1042 (lambda (y)
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1043 "Devious evil mapping function"
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1044 (when (eq (car y) 1)
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1045 (setcdr (cdr x) 42)) ; drop a brick wall onto the freeway
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1046 (car y))
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1047 x)))
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1048
5136
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents: 5036
diff changeset
1049 (Assert (eql
5034
1b96882bdf37 Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4906
diff changeset
1050 (length (multiple-value-list
1b96882bdf37 Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4906
diff changeset
1051 (car (mapcar #'(lambda (argument) (floor argument)) (list pi e)))))
5136
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents: 5036
diff changeset
1052 1)
5034
1b96882bdf37 Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4906
diff changeset
1053 "checking multiple values are correctly discarded in mapcar")
1b96882bdf37 Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4906
diff changeset
1054
5299
28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents: 5295
diff changeset
1055 (let ((malformed-list '(1 2 3 4 hi there . tail)))
28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents: 5295
diff changeset
1056 (Check-Error malformed-list (mapcar #'identity malformed-list))
28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents: 5295
diff changeset
1057 (Check-Error malformed-list (map nil #'eq [1 2 3 4]
28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents: 5295
diff changeset
1058 malformed-list))
28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents: 5295
diff changeset
1059 (Check-Error malformed-list (list-length malformed-list)))
28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents: 5295
diff changeset
1060
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1061 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1062 ;; Test vector functions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1066 (Assert (not (equal [1 2 3] [])))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1067 (Assert (not (equal [1 2 3] [1 2 4])))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1068 (Assert (not (equal [0 2 3] [1 2 3])))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1069 (Assert (not (equal [1 2 3] [1 2 3 4])))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1073
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1074 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1075 ;; Test bit-vector functions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1079 (Assert (not (equal #*010 #*011)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1080 (Assert (not (equal #*010 #*)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1081 (Assert (not (equal #*110 #*010)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1082 (Assert (not (equal #*010 #*0100)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1087
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1088 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1089 ;; Test buffer-local variables used as (ugh!) function parameters
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1090 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1091 (make-local-variable 'test-emacs-buffer-local-variable)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1092 (byte-compile
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1093 (defun test-emacs-buffer-local-parameter (test-emacs-buffer-local-variable)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1094 (setq test-emacs-buffer-local-variable nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1095 (test-emacs-buffer-local-parameter nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1096
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1097 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1098 ;; Test split-string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1099 ;;-----------------------------------------------------
1425
74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent]
stephent
parents: 826
diff changeset
1100 ;; Keep nulls, explicit SEPARATORS
74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent]
stephent
parents: 826
diff changeset
1101 ;; Hrvoje didn't like the next 3 tests so I'm disabling them for now. -sb
74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent]
stephent
parents: 826
diff changeset
1102 ;; I assume Hrvoje worried about the possibility of infloops. -sjt
74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent]
stephent
parents: 826
diff changeset
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
74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent]
stephent
parents: 826
diff changeset
1116 ;; Omit nulls, explicit SEPARATORS
74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent]
stephent
parents: 826
diff changeset
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
74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent]
stephent
parents: 826
diff changeset
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
74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent]
stephent
parents: 826
diff changeset
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
74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent]
stephent
parents: 826
diff changeset
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
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1157
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
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
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1229 ;; Test near-text buffer functions.
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1230 ;;-----------------------------------------------------
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1231 (with-temp-buffer
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
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
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
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
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
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
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
1257 )
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 434
diff changeset
1258
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 434
diff changeset
1259 ;;-----------------------------------------------------
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 434
diff changeset
1260 ;; Test plist manipulation functions.
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 434
diff changeset
1261 ;;-----------------------------------------------------
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 434
diff changeset
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
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 434
diff changeset
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
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 434
diff changeset
1277 )
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1278
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1279 (loop for obj in
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1280 (list (make-symbol "test-symbol")
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1281 "test-string"
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1282 (make-extent nil nil nil)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1283 (make-face 'test-face))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
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
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
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
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
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
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
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
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1297 )
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1298
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1299 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1300 error "Object type has no properties"
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1301 (get 2 'property))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1302
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1303 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1304 error "Object type has no settable properties"
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1305 (put (current-buffer) 'property 'value))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1306
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1307 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1308 error "Object type has no removable properties"
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1309 (remprop ?3 'property))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1310
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1311 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1312 error "Object type has no properties"
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1313 (object-plist (symbol-function 'car)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1314
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1315 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1316 error "Can't remove property from object"
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1317 (remprop (make-extent nil nil nil) 'detachable))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1318
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1319 ;;-----------------------------------------------------
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1320 ;; Test subseq
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
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
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1331
446
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
1332 (Check-Error wrong-type-argument (subseq 3 2))
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
1333 (Check-Error args-out-of-range (subseq [1 2 3] -42))
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
1334 (Check-Error args-out-of-range (subseq [1 2 3] 0 42))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1335
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1336 ;;-----------------------------------------------------
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1337 ;; Time-related tests
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
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
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1340
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1341 ;;-----------------------------------------------------
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1342 ;; format test
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1343 ;;-----------------------------------------------------
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1344 (Assert (string= (format "%d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
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
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1347 (Assert (string= (format "%x" 31) "1f"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
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
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 464
diff changeset
1351 ;; MS-Windows uses +002 in its floating-point numbers. #### We should
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 464
diff changeset
1352 ;; perhaps fix this, but writing our own floating-point support in doprnt.c
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 464
diff changeset
1353 ;; is very hard.
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 464
diff changeset
1354 (Assert (or (string= (format "%e" 100) "1.000000e+02")
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 464
diff changeset
1355 (string= (format "%e" 100) "1.000000e+002")))
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 464
diff changeset
1356 (Assert (or (string= (format "%E" 100) "1.000000E+02")
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 464
diff changeset
1357 (string= (format "%E" 100) "1.000000E+002")))
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 464
diff changeset
1358 (Assert (or (string= (format "%E" 100) "1.000000E+02")
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 464
diff changeset
1359 (string= (format "%E" 100) "1.000000E+002")))
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1360 (Assert (string= (format "%f" 100) "100.000000"))
448
3078fd1074e8 Import from CVS: tag r21-2-39
cvs
parents: 446
diff changeset
1361 (Assert (string= (format "%7.3f" 12.12345) " 12.123"))
3078fd1074e8 Import from CVS: tag r21-2-39
cvs
parents: 446
diff changeset
1362 (Assert (string= (format "%07.3f" 12.12345) "012.123"))
3078fd1074e8 Import from CVS: tag r21-2-39
cvs
parents: 446
diff changeset
1363 (Assert (string= (format "%-7.3f" 12.12345) "12.123 "))
3078fd1074e8 Import from CVS: tag r21-2-39
cvs
parents: 446
diff changeset
1364 (Assert (string= (format "%-07.3f" 12.12345) "12.123 "))
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1365 (Assert (string= (format "%g" 100.0) "100"))
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 464
diff changeset
1366 (Assert (or (string= (format "%g" 0.000001) "1e-06")
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 464
diff changeset
1367 (string= (format "%g" 0.000001) "1e-006")))
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1368 (Assert (string= (format "%g" 0.0001) "0.0001"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1369 (Assert (string= (format "%G" 100.0) "100"))
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 464
diff changeset
1370 (Assert (or (string= (format "%G" 0.000001) "1E-06")
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 464
diff changeset
1371 (string= (format "%G" 0.000001) "1E-006")))
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1372 (Assert (string= (format "%G" 0.0001) "0.0001"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1373
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1374 (Assert (string= (format "%2$d%1$d" 10 20) "2010"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1375 (Assert (string= (format "%-d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1376 (Assert (string= (format "%-4d" 10) "10 "))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1377 (Assert (string= (format "%+d" 10) "+10"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1378 (Assert (string= (format "%+d" -10) "-10"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1379 (Assert (string= (format "%+4d" 10) " +10"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1380 (Assert (string= (format "%+4d" -10) " -10"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1381 (Assert (string= (format "% d" 10) " 10"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1382 (Assert (string= (format "% d" -10) "-10"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1383 (Assert (string= (format "% 4d" 10) " 10"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1384 (Assert (string= (format "% 4d" -10) " -10"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1385 (Assert (string= (format "%0d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1386 (Assert (string= (format "%0d" -10) "-10"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1387 (Assert (string= (format "%04d" 10) "0010"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1388 (Assert (string= (format "%04d" -10) "-010"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1389 (Assert (string= (format "%*d" 4 10) " 10"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1390 (Assert (string= (format "%*d" 4 -10) " -10"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1391 (Assert (string= (format "%*d" -4 10) "10 "))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1392 (Assert (string= (format "%*d" -4 -10) "-10 "))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1393 (Assert (string= (format "%#d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1394 (Assert (string= (format "%#o" 8) "010"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1395 (Assert (string= (format "%#x" 16) "0x10"))
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 464
diff changeset
1396 (Assert (or (string= (format "%#e" 100) "1.000000e+02")
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 464
diff changeset
1397 (string= (format "%#e" 100) "1.000000e+002")))
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 464
diff changeset
1398 (Assert (or (string= (format "%#E" 100) "1.000000E+02")
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 464
diff changeset
1399 (string= (format "%#E" 100) "1.000000E+002")))
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1400 (Assert (string= (format "%#f" 100) "100.000000"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1401 (Assert (string= (format "%#g" 100.0) "100.000"))
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 464
diff changeset
1402 (Assert (or (string= (format "%#g" 0.000001) "1.00000e-06")
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 464
diff changeset
1403 (string= (format "%#g" 0.000001) "1.00000e-006")))
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1404 (Assert (string= (format "%#g" 0.0001) "0.000100000"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1405 (Assert (string= (format "%#G" 100.0) "100.000"))
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 464
diff changeset
1406 (Assert (or (string= (format "%#G" 0.000001) "1.00000E-06")
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 464
diff changeset
1407 (string= (format "%#G" 0.000001) "1.00000E-006")))
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1408 (Assert (string= (format "%#G" 0.0001) "0.000100000"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1409 (Assert (string= (format "%.1d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1410 (Assert (string= (format "%.4d" 10) "0010"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1411 ;; Combination of `-', `+', ` ', `0', `#', `.', `*'
448
3078fd1074e8 Import from CVS: tag r21-2-39
cvs
parents: 446
diff changeset
1412 (Assert (string= (format "%-04d" 10) "10 "))
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1413 (Assert (string= (format "%-*d" 4 10) "10 "))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1414 ;; #### Correctness of this behavior is questionable.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1415 ;; It might be better to signal error.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1416 (Assert (string= (format "%-*d" -4 10) "10 "))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1417 ;; These behavior is not specified.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1418 ;; (format "%-+d" 10)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1419 ;; (format "%- d" 10)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1420 ;; (format "%-01d" 10)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1421 ;; (format "%-#4x" 10)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1422 ;; (format "%-.1d" 10)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1423
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1424 (Assert (string= (format "%01.1d" 10) "10"))
448
3078fd1074e8 Import from CVS: tag r21-2-39
cvs
parents: 446
diff changeset
1425 (Assert (string= (format "%03.1d" 10) " 10"))
3078fd1074e8 Import from CVS: tag r21-2-39
cvs
parents: 446
diff changeset
1426 (Assert (string= (format "%01.3d" 10) "010"))
3078fd1074e8 Import from CVS: tag r21-2-39
cvs
parents: 446
diff changeset
1427 (Assert (string= (format "%1.3d" 10) "010"))
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1428 (Assert (string= (format "%3.1d" 10) " 10"))
446
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
1429
448
3078fd1074e8 Import from CVS: tag r21-2-39
cvs
parents: 446
diff changeset
1430 ;;; The following two tests used to use 1000 instead of 100,
3078fd1074e8 Import from CVS: tag r21-2-39
cvs
parents: 446
diff changeset
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
3078fd1074e8 Import from CVS: tag r21-2-39
cvs
parents: 446
diff changeset
1434
446
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
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
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
1442
4287
89e64783d068 [xemacs-hg @ 2007-11-27 13:51:03 by aidan]
aidan
parents: 2075
diff changeset
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
89e64783d068 [xemacs-hg @ 2007-11-27 13:51:03 by aidan]
aidan
parents: 2075
diff changeset
1446
446
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
1447 ;;; "%u" is undocumented, and Emacs Lisp has no unsigned type.
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
1448 ;;; What to do if "%u" is used with a negative number?
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
1449 ;;; For non-bignum XEmacsen, the most reasonable thing seems to be to print an
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
1450 ;;; un-read-able number. The printed value might be useful to a human, if not
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
1451 ;;; to Emacs Lisp.
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
1452 ;;; For bignum XEmacsen, we make %u with a negative value throw an error.
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
1453 (if (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
1454 (progn
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
1455 (Check-Error wrong-type-argument (format "%u" most-negative-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
1456 (Check-Error wrong-type-argument (format "%u" -1)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
1457 (Check-Error invalid-read-syntax (read (format "%u" most-negative-fixnum)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1425
diff changeset
1458 (Check-Error invalid-read-syntax (read (format "%u" -1))))
448
3078fd1074e8 Import from CVS: tag r21-2-39
cvs
parents: 446
diff changeset
1459
3078fd1074e8 Import from CVS: tag r21-2-39
cvs
parents: 446
diff changeset
1460 ;; Check all-completions ignore element start with space.
3078fd1074e8 Import from CVS: tag r21-2-39
cvs
parents: 446
diff changeset
1461 (Assert (not (all-completions "" '((" hidden" . "object")))))
3078fd1074e8 Import from CVS: tag r21-2-39
cvs
parents: 446
diff changeset
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