xemacs-beta: tests/automated/lisp-tests.el annotate

annotate tests/automated/lisp-tests.el @ 5797:a1808d52a34a

If the position of a window's cached point is deleted, use buffer point instead src/ChangeLog addition: 2014-06-17 Aidan Kehoe <kehoea@parhasard.net> * extents.h: * window.c: * window.c (unshow_buffer): * window.c (Fset_window_buffer): Use extents, rather than markers, for the window buffer point cache, so that when the text containing that window buffer point is deleted, the window display code uses the buffer's actual point instead of the position that the marker had been moved to. Fixes Michael Heinrich's problem of http://mid.gmane.org/6zr42uxtf5.fsf@elektra.science-computing.de , introduced by Ben's patch of https://bitbucket.org/xemacs/xemacs/commits/047d37eb70d70f43803 .

author	Aidan Kehoe <kehoea@parhasard.net>
date	Tue, 17 Jun 2014 20:55:45 +0100
parents	cd4f5f1f1f4c
children	e9bb3688e654 750fab17b299

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
5402 308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	11 ;; XEmacs is free software: you can redistribute it and/or modify it
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	12 ;; under the terms of the GNU General Public License as published by the
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	13 ;; Free Software Foundation, either version 3 of the License, or (at your
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	14 ;; option) any later version.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	15
5402 308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	16 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	17 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	18 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	19 ;; for more details.
428 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
5402 308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	22 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	23
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	24 ;;; Synched up with: Not in FSF.
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 ;;; Commentary:
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 ;;; Test basic Lisp engine functionality
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	29 ;;; See test-harness.el for instructions on how to run these tests.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	30
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	31 (eval-when-compile
5772 cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	32 ;; The labels below give trouble with a max-lisp-eval-depth of less than
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	33 ;; about 2000, work around that:
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	34 (setq max-lisp-eval-depth (max 2000 max-lisp-eval-depth))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	35 (condition-case nil
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	36 (require 'test-harness)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	37 (file-error
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	38 (push "." load-path)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	39 (when (and (boundp 'load-file-name) (stringp load-file-name))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	40 (push (file-name-directory load-file-name) load-path))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	41 (require 'test-harness))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	42
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	43 (Check-Error wrong-number-of-arguments (setq setq-test-foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	44 (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	45 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	46 (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	47 (Assert (eq (setq) 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-default) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	49 (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	50 (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	51 (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	52 (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	53
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	54 (macrolet ((test-setq (expected-result &rest body)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	55 `(progn
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	56 (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	57 (Assert (eq ,expected-result (test-setq-fun)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	58 (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	59 (Assert (eq ,expected-result (test-setq-fun))))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	60 (test-setq nil (setq))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	61 (test-setq nil (setq-default))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	62 (test-setq 42 (setq test-setq-var 42))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	63 (test-setq 42 (setq-default test-setq-var 42))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	64 (test-setq 42 (setq test-setq-bar 99 test-setq-var 42))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	65 (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	66 )
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	67
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	68 (let ((my-vector [1 2 3 4])
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	69 (my-bit-vector (bit-vector 1 0 1 0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	70 (my-string "1234")
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	71 (my-list '(1 2 3 4)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	72
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	73 ;;(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	74 ;;(Assert (eq 1 2)) ;; Generate Assertion failure
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	75
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	76 (dolist (sequence (list my-vector my-bit-vector my-string my-list))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	77 (Assert (sequencep sequence))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	78 (Assert (eq 4 (length sequence))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	79
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	80 (dolist (array (list my-vector my-bit-vector my-string))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	81 (Assert (arrayp array)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	82
5136 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-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-bit-vector 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-string 0) ?1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	86 (Assert (eq (elt my-list 0) 1))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	87
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	88 (fillarray my-vector 5)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	89 (fillarray my-bit-vector 1)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	90 (fillarray my-string ?5)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	91
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	92 (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	93 (Assert (eq 4 (length array))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	94
5136 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-vector 0) 5))
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-bit-vector 0) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	97 (Assert (eq (elt my-string 0) ?5))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	98
5136 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-vector 3) 5))
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-bit-vector 3) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	101 (Assert (eq (elt my-string 3) ?5))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	102
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	103 (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	104 (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	105 (Assert (eq (elt my-bit-vector 2) 0))
428 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
5772 cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	108 (defun make-circular-list (length &optional value)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	109 "Create evil emacs-crashing circular list of length LENGTH.
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	110
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	111 Optional VALUE is the value to go into the cars. If nil, some non-nil value
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	112 will be used to make debugging easier."
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	113 (let ((circular-list
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	114 (make-list
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	115 length
5772 cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	116 (or value
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	117 'you-are-trapped-in-a-twisty-maze-of-cons-cells-all-alike))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	118 (setcdr (last circular-list) circular-list)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	119 circular-list))
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 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	122 ;; Test `nconc'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	123 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	124 (defun make-list-012 () (list 0 1 2))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	125
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	126 (Check-Error wrong-type-argument (nconc 'foo nil))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	127
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	128 (dolist (length '(1 2 3 4 1000 2000))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	129 (Check-Error circular-list (nconc (make-circular-list length) 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	130 (Check-Error circular-list (nconc '(1 . 2) (make-circular-list length) 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	131 (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	132
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	133 (Assert (eq (nconc) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	134 (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	135 (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	136 (Assert (eq (nconc nil nil nil) nil))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	137
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	138 (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	139 (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	140 (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	141 (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	142 (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	143
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	144 (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	145
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	146 (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	147 (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	148 (Assert (eq (nth 3 y) 3)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	149
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	150 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	151 ;; Test `last'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	152 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	153 (Check-Error wrong-type-argument (last 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	154 (Check-Error wrong-number-of-arguments (last))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	155 (Check-Error wrong-number-of-arguments (last '(1 2) 1 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	156 (Check-Error circular-list (last (make-circular-list 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	157 (Check-Error circular-list (last (make-circular-list 2000)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	158 (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	159 (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	160 (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	161 (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	162 (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	163 (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	164 (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	165 (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	166 (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	167 (Assert (eq (last '(1 . 2) 0) 2))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	168 )
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	169
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	170 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	171 ;; Test `butlast' and `nbutlast'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	172 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	173 (Check-Error wrong-type-argument (butlast 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	174 (Check-Error wrong-type-argument (nbutlast 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	175 (Check-Error wrong-number-of-arguments (butlast))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	176 (Check-Error wrong-number-of-arguments (nbutlast))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	177 (Check-Error wrong-number-of-arguments (butlast '(1 2) 1 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	178 (Check-Error wrong-number-of-arguments (nbutlast '(1 2) 1 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	179 (Check-Error circular-list (butlast (make-circular-list 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	180 (Check-Error circular-list (nbutlast (make-circular-list 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	181 (Check-Error circular-list (butlast (make-circular-list 2000)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	182 (Check-Error circular-list (nbutlast (make-circular-list 2000)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	183
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	184 (let* ((x (list 0 1 2 3))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	185 (y (butlast x))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	186 (z (nbutlast x)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	187 (Assert (eq z x))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	188 (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	189 (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	190 (Assert (equal z y)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	191
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	192 (let* ((x (list 0 1 2 3 4))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	193 (y (butlast x 2))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	194 (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	195 (Assert (eq z x))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	196 (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	197 (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	198 (Assert (equal z y)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	199
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	200 (let* ((x (list 0 1 2 3))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	201 (y (butlast x 0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	202 (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	203 (Assert (eq z x))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	204 (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	205 (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	206 (Assert (equal z y)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	207
5285 99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	208 (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	209 (y (butlast x 0))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	210 (z (nbutlast x 0)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	211 (Assert (eq z x))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	212 (Assert (not (eq y x)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	213 (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	214 (Assert (equal z y)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	215
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	216 (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	217 (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	218 (Assert (eq (butlast '()) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	219 (Assert (eq (nbutlast '()) nil))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	220
5307 c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	221 (when (featurep 'bignum)
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	222 (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	223 (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	224 (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	225 (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	226 (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	227 (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	228 (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	229 "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	230
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	231 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	232 ;; Test `copy-list'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	233 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	234 (Check-Error wrong-type-argument (copy-list 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	235 (Check-Error wrong-number-of-arguments (copy-list))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	236 (Check-Error wrong-number-of-arguments (copy-list '(1 2) 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	237 (Check-Error circular-list (copy-list (make-circular-list 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	238 (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	239 (Assert (eq '() (copy-list '())))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	240 (dolist (x '((1) (1 2) (1 2 3) (1 2 . 3)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	241 (let ((y (copy-list x)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	242 (Assert (and (equal x y) (not (eq x y))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	243
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	244 ;;-----------------------------------------------------
5285 99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	245 ;; Test `ldiff'
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	246 ;;-----------------------------------------------------
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	247 (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	248 (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	249 (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	250 (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	251 (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	252 (Assert (eq '() (ldiff '() pi)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	253 (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	254 (let ((y (ldiff x nil)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	255 (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	256
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	257 (let* ((vector (vector 'foo))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	258 (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	259 (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	260 without-vector without-pi)
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	261 (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	262 "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	263 (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	264 "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	265 (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	266 "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	267
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	268 ;;-----------------------------------------------------
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	269 ;; Test `tailp'
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	270 ;;-----------------------------------------------------
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	271 (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	272 (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	273 (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	274 (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	275 (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	276 (Assert (null (tailp pi '()))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	277 "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	278 (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	279 "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	280 (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	281 "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	282 (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	283 (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	284 "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	285
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	286 ;;-----------------------------------------------------
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	287 ;; Test `endp'
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	288 ;;-----------------------------------------------------
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	289 (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	290 (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	291 (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	292 (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	293 (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	294 "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	295
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	296 ;;-----------------------------------------------------
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	297 ;; Arithmetic operations
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	298 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	299
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	300 ;; Test `+'
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	301 (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	302 (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	303 (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	304 (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	305 (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	306 (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	307 (Assert (= (+ 1 1 1.0) 3.0))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	308 (if (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	309 (progn
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	310 (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	311 (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	312 (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	313 (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	314 (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	315 (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	316 3))))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	317 (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	318 (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	319
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	320 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	321 (let ((threefourths (read "3/4"))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	322 (threehalfs (read "3/2"))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	323 (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	324 (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	325 (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	326 (Assert (= negone -1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	327 (Assert (= threehalfs (+ threefourths threefourths)))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	328 (Assert (zerop (+ bigpos bigneg)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	329
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	330 ;; Test `-'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	331 (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	332 (Assert (eq (- 0) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	333 (Assert (eq (- 1) -1))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	334 (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	335 (Assert (= (+ 1 one) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	336 (Assert (= (+ one) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	337 (Assert (= (+ one) one))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	338 (Assert (= (- one) -1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	339 (Assert (= (- one one) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	340 (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	341 (Assert (= (- 0 one) -1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	342 (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	343 (Assert (= (+ one 1) 2))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	344 (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	345 (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	346 (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	347 (Assert (= (- zero) zero) zero)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	348 (Assert (= (- zero) 0) zero)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	349 (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	350 (Assert (= (- zero one one) -2) zero)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	351
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	352 (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	353 (Assert (= (- 1 1.5) (- .5)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	354
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	355 (if (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	356 (progn
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	357 (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	358 (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	359 (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	360 (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	361 (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	362 (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	363 (* 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	364 1)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	365 (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	366 (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	367
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	368 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	369 (let ((threefourths (read "3/4"))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	370 (threehalfs (read "3/2"))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	371 (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	372 (bigneg (div most-positive-fixnum most-negative-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	373 (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	374 (Assert (= (- negone) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	375 (Assert (= threefourths (- threehalfs threefourths)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	376 (Assert (= (- bigpos bigneg) 2))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	377
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	378 ;; Test `/'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	379
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	380 ;; Test division by zero errors
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	381 (dolist (zero '(0 0.0 ?\0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	382 (Check-Error arith-error (/ zero))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	383 (dolist (n1 `(42 42.0 ?\042 ,(Int-to-Marker 42)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	384 (Check-Error arith-error (/ n1 zero))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	385 (dolist (n2 `(3 3.0 ?\03 ,(Int-to-Marker 3)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	386 (Check-Error arith-error (/ n1 n2 zero)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	387
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	388 ;; Other tests for `/'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	389 (Check-Error wrong-number-of-arguments (/))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	390 (let (x)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	391 (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	392 (Assert (= (/ (setq x 2.0)) 0.5)))
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 (six '(6 6.0 ?\06))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	395 (dolist (two '(2 2.0 ?\02))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	396 (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	397 (Assert (= (/ six two) three) (list six two three)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	398
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	399 (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	400 (Assert (= (/ three 2.0) 1.5) three))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	401 (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	402 (Assert (= (/ 3.0 two) 1.5) two))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	403
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	404 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	405 (let* ((million 1000000)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	406 (billion (* million 1000)) ;; American, not British, billion
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	407 (trillion (* billion 1000)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	408 (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	409 (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	410 (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	411 (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	412 (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	413 (Assert (= (/ (- trillion) 10) (* -100 billion) -100000000000.0))))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	414
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	415 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	416 (let ((half (div 1 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	417 (fivefourths (div 5 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	418 (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	419 (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	420 (Assert (= (/ fivehalfs fivefourths) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	421 (Assert (= (/ fivefourths fivehalfs) half))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	422 (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	423 (Assert (= (/ fivehalfs (- fivefourths)) -2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	424 (Assert (= (/ (- fivefourths) fivehalfs) (- half)))))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	425
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	426 ;; Test `*'
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	427 (Assert (= 1 (*)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	428
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	429 (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	430 (Assert (= 1 (* one)) one))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	431
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	432 (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	433 (Assert (= 2 (* two)) two))
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 (six '(6 6.0 ?\06))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	436 (dolist (two '(2 2.0 ?\02))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	437 (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	438 (Assert (= (* three two) six) (list three two six)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	439
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	440 (dolist (three '(3 3.0 ?\03))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	441 (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	442 (Assert (= (* 1.5 two) three) (list two three))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	443 (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	444 (Assert (= 30 (* five two three)) (list five two three)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	445
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	446 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	447 (let ((64K 65536))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	448 (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	449 (Assert (= (* (- 64K) 64K) (read "-4294967296")))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	450 (Assert (/= (* -1 most-negative-fixnum) most-negative-fixnum))))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	451
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	452 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	453 (let ((half (div 1 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	454 (fivefourths (div 5 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	455 (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	456 (Assert (= (* fivefourths twofifths) half))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	457 (Assert (= (* half twofifths) (read "3/15")))))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	458
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	459 ;; Test `+'
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	460 (Assert (= 0 (+)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	461
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	462 (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	463 (Assert (= 1 (+ one)) one))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	464
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	465 (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	466 (Assert (= 2 (+ two)) two))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	467
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	468 (dolist (five '(5 5.0 ?\05))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	469 (dolist (two '(2 2.0 ?\02))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	470 (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	471 (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	472 (Assert (= 10 (+ five two three)) (list five two three)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	473
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	474 ;; Test `max', `min'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	475 (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	476 (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	477 (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	478 (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	479 (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	480 (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	481 (Assert (= one (min one one one)) one)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	482 (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	483 (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	484 (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	485 (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	486 (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	487 (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	488 (Assert (= two (max two two one)) (list one two))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	489
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	490 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	491 (let ((big (1+ most-positive-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	492 (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	493 (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	494 (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	495
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	496 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	497 (let* ((big (1+ most-positive-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	498 (small (1- most-negative-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	499 (bigr (div (* 5 (1+ most-positive-fixnum)) 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	500 (smallr (- bigr)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	501 (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	502 (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	503
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	504 ;; The byte compiler has special handling for these constructs:
1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	505 (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	506 (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	507 (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	508 (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	509 (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	510 (Assert (= (+ three 1) 4))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	511 (Assert (= (+ three -1) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	512 (Assert (= (+ -1 three) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	513 (Assert (= (+ -1 three) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	514 (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	515 (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	516 (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	517 (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	518 (Assert (= (- three 1) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	519 (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	520 (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	521 (Assert (= (- three -1) 4))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	522 (Assert (= (- three 0) 3))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	523 (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	524 (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	525 (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	526 (Assert (= (* three 2) 6))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	527 (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	528 (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	529 (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	530 (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	531 (Assert (= (/ three 1) 3))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	532 (Assert (= (/ three -1) -3))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	533 (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	534 (Assert (= (/ 64 five 2) 6)))
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	535
1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	536
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	537 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	538 ;; Logical bit-twiddling operations
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	539 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	540 (Assert (= (logxor) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	541 (Assert (= (logior) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	542 (Assert (= (logand) -1))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	543
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	544 (Check-Error wrong-type-argument (logxor 3.0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	545 (Check-Error wrong-type-argument (logior 3.0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	546 (Check-Error wrong-type-argument (logand 3.0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	547
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	548 (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	549 (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	550 (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	551 (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	552 (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	553 (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	554 (Assert (eq 3 (logior three three))) three)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	555
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	556 (dolist (one `(1 ?\01 ,(Int-to-Marker 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	557 (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	558 (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	559 (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	560 (Assert (eq 3 (logxor one two)) (list one two)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	561 (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	562 (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	563 (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	564 (Assert (eq 2 (logxor one three)) (list one three))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	565
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	566 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	567 ;; Test `%', mod
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	568 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	569 (Check-Error wrong-number-of-arguments (%))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	570 (Check-Error wrong-number-of-arguments (% 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	571 (Check-Error wrong-number-of-arguments (% 1 2 3))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	572
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	573 (Check-Error wrong-number-of-arguments (mod))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	574 (Check-Error wrong-number-of-arguments (mod 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	575 (Check-Error wrong-number-of-arguments (mod 1 2 3))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	576
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	577 (Check-Error wrong-type-argument (% 10.0 2))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	578 (Check-Error wrong-type-argument (% 10 2.0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	579
5576 071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	580 (labels ((test1 (x) (Assert (eql x (+ (% x 17) (* (/ x 17) 17))) x))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	581 (test2 (x) (Assert (eql (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17))) x))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	582 (test3 (x) (Assert (eql x (+ (% (- x) 17) (* (/ (- x) 17) 17))) x))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	583 (test4 (x) (Assert (eql (% x -17) (- (% (- x) 17))) x))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	584 (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	585 (test1 most-negative-fixnum)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	586 (if (featurep 'bignum)
2075 c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james] james parents: 2056 diff changeset	587 (progn
c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james] james parents: 2056 diff changeset	588 (test2 most-negative-fixnum)
c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james] james parents: 2056 diff changeset	589 (test4 most-negative-fixnum))
c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james] james parents: 2056 diff changeset	590 (test3 most-negative-fixnum)
c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james] james parents: 2056 diff changeset	591 (test5 most-negative-fixnum))
2056 ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	592 (test1 most-positive-fixnum)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	593 (test2 most-positive-fixnum)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	594 (test4 most-positive-fixnum)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	595 (dotimes (j 30)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	596 (let ((x (random)))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	597 (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	598 (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	599 (test1 x)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	600 (test2 x)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	601 (test4 x))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	602
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	603 (macrolet
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	604 ((division-test (seven)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	605 `(progn
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 2) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	607 (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	608 (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	609 (Assert (eq (% (- ,seven) -2) -1))
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 (% ,seven 4) 3))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	612 (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	613 (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	614 (Assert (eq (% (- ,seven) -4) -3))
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 (% 35 ,seven) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	617 (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	618 (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	619 (Assert (eq (% -35 (- ,seven)) 0))
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 2) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	622 (Assert (eq (mod ,seven -2) -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) 2) 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) -2) -1))
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 ,seven 4) 3))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	627 (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	628 (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	629 (Assert (eq (mod (- ,seven) -4) -3))
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 (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	632 (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	633 (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	634 (Assert (eq (mod -35 (- ,seven)) 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 2.0) 1.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	637 (Assert (= (mod ,seven -2.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) 2.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) -2.0) -1.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 (= (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	642 (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	643 (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	644 (Assert (= (mod (- ,seven) -4.0) -3.0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	645
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	646 (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	647 (Assert (eq (% 0 (- ,seven)) 0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	648
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	649 (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	650 (Assert (eq (mod 0 (- ,seven)) 0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	651
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	652 (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	653 (Assert (= (mod 0.0 (- ,seven)) 0.0)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	654
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	655 (division-test 7)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	656 (division-test ?\07)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	657 (division-test (Int-to-Marker 7)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	658
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	659 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	660 (let ((big (+ (* 7 most-positive-fixnum 6)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	661 (negbig (- (* 7 most-negative-fixnum 6))))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	662 (= (% big (1+ most-positive-fixnum)) most-positive-fixnum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	663 (= (% negbig (1- most-negative-fixnum)) most-negative-fixnum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	664 (= (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	665 (= (mod negbig (1- most-negative-fixnum)) most-negative-fixnum)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	666
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	667 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	668 ;; Arithmetic comparison operations
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	669 ;;-----------------------------------------------------
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 (Check-Error wrong-number-of-arguments (<))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	672 (Check-Error wrong-number-of-arguments (>))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	673 (Check-Error wrong-number-of-arguments (<=))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	674 (Check-Error wrong-number-of-arguments (>=))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	675 (Check-Error wrong-number-of-arguments (/=))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	676
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	677 ;; One argument always yields t
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	678 (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	679 (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	680 (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	681 (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	682 (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	683 (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	684 (Assert (eq t (/= x)) x)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	685 )
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	686
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	687 ;; Type checking
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 (Check-Error wrong-type-argument (<= 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	690 (Check-Error wrong-type-argument (>= 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	691 (Check-Error wrong-type-argument (< 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	692 (Check-Error wrong-type-argument (> 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	693 (Check-Error wrong-type-argument (/= 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	694
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	695 ;; Meat
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	696 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	697 (dolist (two '(2 2.0 ?\02))
2056 ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	698 (Assert (< one two) (list one 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 (<= two two) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	701 (Assert (> two one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	702 (Assert (>= two one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	703 (Assert (>= two two) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	704 (Assert (/= one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	705 (Assert (not (/= two two)) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	706 (Assert (not (< one one)) one)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	707 (Assert (not (> one one)) one)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	708 (Assert (<= one one two two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	709 (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	710 (Assert (>= two two one one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	711 (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	712 (Assert (= one one one) one)
2056 ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	713 (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	714 (Assert (not (/= one two one)) (list one two))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	715 ))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	716
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	717 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	718 (dolist (two '(2 2.0 ?\02))
2056 ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	719 (Assert (< one two) (list one 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 (<= two two) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	722 (Assert (> two one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	723 (Assert (>= two one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	724 (Assert (>= two two) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	725 (Assert (/= one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	726 (Assert (not (/= two two)) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	727 (Assert (not (< one one)) one)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	728 (Assert (not (> one one)) one)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	729 (Assert (<= one one two two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	730 (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	731 (Assert (>= two two one one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	732 (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	733 (Assert (= one one one) one)
2056 ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	734 (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	735 (Assert (not (/= one two one)) (list one two))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	736 ))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	737
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	738 ;; ad-hoc
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	739 (Assert (< 1 2))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	740 (Assert (< 1 2 3 4 5 6))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	741 (Assert (not (< 1 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	742 (Assert (not (< 2 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	743
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	744
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	745 (Assert (not (< 1 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	746 (Assert (< 1 2 3 4 5 6))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	747 (Assert (<= 1 2 3 4 5 6))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	748 (Assert (<= 1 2 3 4 5 6 6))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	749 (Assert (not (< 1 2 3 4 5 6 6)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	750 (Assert (<= 1 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	751
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	752 (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	753 (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	754 (Assert (= (point) (point-marker)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	755
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	756 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	757 (let ((big1 (1+ most-positive-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	758 (big2 (* 10 most-positive-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	759 (small1 (1- most-negative-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	760 (small2 (* 10 most-negative-fixnum)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	761 (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	762 big2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	763 (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	764 big2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	765 (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	766 small2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	767 (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	768 small2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	769 (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	770 big2))))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	771
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	772 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	773 (let ((big1 (div (* 10 most-positive-fixnum) 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	774 (big2 (div (* 5 most-positive-fixnum) 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	775 (big3 (div (* 7 most-positive-fixnum) 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	776 (small1 (div (* 10 most-negative-fixnum) 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	777 (small2 (div (* 5 most-negative-fixnum) 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	778 (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	779 (Assert (= big1 big2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	780 (Assert (= small1 small2))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	781 (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	782 big3))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	783 (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	784 big1 big2 big3))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	785 (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	786 small3))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	787 (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	788 small1 small2 small3))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	789 (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	790 small3))))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	791
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	792 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	793 ;; testing list-walker functions
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	794 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	795 (macrolet
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	796 ((test-fun
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	797 (fun)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	798 `(progn
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	799 (Check-Error wrong-number-of-arguments (,fun))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	800 (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	801 (Check-Error (malformed-list wrong-type-argument) (,fun nil 1))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	802 ,@(loop for n in '(1 2 2000)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	803 collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n))))))
5374 d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	804 (test-funs (&rest funs) `(progn ,@(loop for fun in funs collect `(test-fun ,fun))))
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	805 (test-old-funs (&rest funs)
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	806 `(when (and (fboundp 'old-eq) (subrp (symbol-function 'old-eq)))
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	807 ,@(loop for fun in funs collect `(test-fun ,fun)))))
5346 b4ef3128160c Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq. Aidan Kehoe <kehoea@parhasard.net> parents: 5339 diff changeset	808 (test-funs member* member memq
b4ef3128160c Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq. Aidan Kehoe <kehoea@parhasard.net> parents: 5339 diff changeset	809 assoc* assoc assq
b4ef3128160c Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq. Aidan Kehoe <kehoea@parhasard.net> parents: 5339 diff changeset	810 rassoc* rassoc rassq
b4ef3128160c Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq. Aidan Kehoe <kehoea@parhasard.net> parents: 5339 diff changeset	811 delete* delete delq
b4ef3128160c Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq. Aidan Kehoe <kehoea@parhasard.net> parents: 5339 diff changeset	812 remove* remove remq
5374 d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	813 remassoc remassq remrassoc remrassq)
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	814 (test-old-funs old-member old-memq old-assoc old-assq old-rassoc old-rassq
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	815 old-delete old-delq))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	816
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	817 (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	818 (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	819 (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	820 (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	821 (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	822 (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	823 (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	824 (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	825 (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	826 (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	827 (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	828 (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	829 (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	830 (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	831 (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	832 (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	833 (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	834 (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	835 (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	836 (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	837 (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	838 (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	839 (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	840 (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	841 (Assert (eq (rassq 6 x) nil)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	842
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	843 (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	844 (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	845 (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	846 (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	847 (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	848 (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	849 (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	850 (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	851 (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	852 (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	853 (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	854 (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	855 (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	856 (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	857 (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	858 (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	859 (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	860 (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	861 (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	862 (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	863 (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	864 (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	865 (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	866 (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	867 (Assert (eq (rassq "6" x) nil)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	868
5576 071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	869 (labels ((a () (list '(1 . 2) 3 '(4 . 5))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	870 (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	871 (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	872 (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	873 (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	874
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	875 (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	876 (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	877 (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	878 (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	879
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	880 (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	881 (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	882 (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	883 (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	884
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	885 (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	886 (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	887 (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	888 (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	889
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	890 (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	891 (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	892 (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	893 (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	894
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	895 (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	896 (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	897 (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	898 (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	899 (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	900 (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	901 (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	902 (Assert (let* ((x (a)) (y (delq '(1 . 2) x))) (and (eq x y) (equal y (a)))))
5374 d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	903 (when (and (fboundp 'old-eq) (subrp (symbol-function 'old-eq)))
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	904 (Assert (let* ((x (a)) (y (old-delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	905 (Assert (let* ((x (a)) (y (old-delq '(1 . 2) x))) (and (eq x y) (equal y (a)))))
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	906 (Assert (let* ((x (a)) (y (old-delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	907 (Assert (let* ((x (a)) (y (old-delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	908
5576 071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	909 (labels ((a () (list '("1" . "2") "3" '("4" . "5"))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	910 (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	911 (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	912 (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	913 (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	914
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	915 (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	916 (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	917 (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	918 (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	919
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	920 (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	921 (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	922 (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	923 (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	924
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	925 (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	926 (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	927 (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	928 (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	929
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	930 (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	931 (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	932 (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	933 (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	934
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	935 (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	936 (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	937 (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	938 (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	939
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	940 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	941 ;; function-max-args, function-min-args
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	942 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	943 (defmacro check-function-argcounts (fun min max)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	944 `(progn
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	945 (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	946 (Assert (eq (function-max-args ,fun) ,max))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	947
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	948 (check-function-argcounts 'prog1 1 nil) ; special form
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	949 (check-function-argcounts 'command-execute 1 3) ; normal subr
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	950 (check-function-argcounts 'funcall 1 nil) ; `MANY' subr
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	951 (check-function-argcounts 'garbage-collect 0 0) ; no args subr
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	952
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	953 ;; Test interpreted and compiled functions
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	954 (loop for (arglist min max) in
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	955 '(((arg1 arg2 &rest args) 2 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	956 ((arg1 arg2 &optional arg3 arg4) 2 4)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	957 ((arg1 arg2 &optional arg3 arg4 &rest args) 2 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	958 (() 0 0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	959 do
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	960 (eval
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	961 `(progn
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	962 (defun test-fun ,arglist nil)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	963 (check-function-argcounts '(lambda ,arglist nil) ,min ,max)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	964 (check-function-argcounts (byte-compile '(lambda ,arglist nil)) ,min ,max))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	965
4575 eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	966 ;; Test subr-arity.
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	967 (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	968 '((let (1 . unevalled))
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	969 (prog1 (1 . unevalled))
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	970 (list (0 . many))
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	971 (type-of (1 . 1))
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	972 (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	973 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	974
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	975 (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	976 (lambda () (message "Hi there!"))))
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	977
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	978 (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	979
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	980 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	981 ;; Detection of cyclic variable indirection loops
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	982 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	983 (fset 'test-sym1 'test-sym1)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	984 (Check-Error cyclic-function-indirection (test-sym1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	985
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	986 (fset 'test-sym1 'test-sym2)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	987 (fset 'test-sym2 'test-sym1)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	988 (Check-Error cyclic-function-indirection (test-sym1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	989 (fmakunbound 'test-sym1) ; else macroexpand-internal infloops!
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	990 (fmakunbound 'test-sym2)
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 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	993 ;; Test `type-of'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	994 ;;-----------------------------------------------------
5136 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 load-path) 'cons))
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 obarray) 'vector))
5595 391d809fa4e9 Update tests that have started failing because of changed design decisions. Aidan Kehoe <kehoea@parhasard.net> parents: 5576 diff changeset	997 (Assert (eq (type-of 42) 'fixnum))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	998 (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	999 (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	1000 (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	1001 (Assert (eq (type-of (selected-device)) 'device))
428 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 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1004 ;; Test mapping functions
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1005 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1006 (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	1007 (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	1008 (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	1009 (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	1010 (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	1011 (Assert (equal (mapcar #'identity #*010) '(0 1 0)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1012
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1013 (let ((z 0) (list (make-list 1000 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1014 (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	1015 (Assert (eq 1000 z)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1016
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1017 (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	1018 (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	1019 (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	1020 (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	1021 (Assert (equal (mapvector #'identity #*010) [0 1 0]))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1022
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1023 (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	1024 (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	1025 (Assert (equal (mapconcat #'identity ["1" "2" "3"] "\|") "1\|2\|3"))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1026
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1027 ;; The following 2 functions used to crash XEmacs via mapcar1().
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1028 ;; 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	1029 (Assert
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1030 (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	1031 (mapcar
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1032 (lambda (y)
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1033 "Devious evil mapping function"
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1034 (when (eq (car y) 2) ; go out onto a limb
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1035 (setcdr x nil) ; cut it off behind us
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1036 (garbage-collect)) ; are we riding a magic broomstick?
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1037 (car y)) ; sorry, hard landing
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1038 x)))
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1039
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1040 (Assert
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1041 (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	1042 (mapcar
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1043 (lambda (y)
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1044 "Devious evil mapping function"
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1045 (when (eq (car y) 1)
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1046 (setcdr (cdr x) 42)) ; drop a brick wall onto the freeway
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1047 (car y))
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1048 x)))
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1049
5355 70b15ac66ee5 Correct a bug with circularity checking in #'mapcar, #'map, etc. Aidan Kehoe <kehoea@parhasard.net>* parents: 5353 diff changeset	1050 (Assert
70b15ac66ee5 Correct a bug with circularity checking in #'mapcar, #'map, etc. Aidan Kehoe <kehoea@parhasard.net>* parents: 5353 diff changeset	1051 (equal
70b15ac66ee5 Correct a bug with circularity checking in #'mapcar, #'map, etc. Aidan Kehoe <kehoea@parhasard.net>* parents: 5353 diff changeset	1052 (let ((list (list pi))) (mapcar* #'cons [1 2 3 4] (nconc list list)))
70b15ac66ee5 Correct a bug with circularity checking in #'mapcar, #'map, etc. Aidan Kehoe <kehoea@parhasard.net>* parents: 5353 diff changeset	1053 `((1 . ,pi) (2 . ,pi) (3 . ,pi) (4 . ,pi)))
70b15ac66ee5 Correct a bug with circularity checking in #'mapcar, #'map, etc. Aidan Kehoe <kehoea@parhasard.net>* parents: 5353 diff changeset	1054 "checking mapcar* behaves correctly when only one arg is circular")
70b15ac66ee5 Correct a bug with circularity checking in #'mapcar, #'map, etc. Aidan Kehoe <kehoea@parhasard.net>* parents: 5353 diff changeset	1055
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1056 (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	1057 (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	1058 (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	1059 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	1060 "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	1061
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	1062 (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	1063 (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	1064 (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	1065 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	1066 (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	1067
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1068 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1069 ;; Test vector functions
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1070 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1071 (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	1072 (Assert (equal [] []))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1073 (Assert (not (equal [1 2 3] [])))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1074 (Assert (not (equal [1 2 3] [1 2 4])))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1075 (Assert (not (equal [0 2 3] [1 2 3])))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1076 (Assert (not (equal [1 2 3] [1 2 3 4])))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1077 (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	1078 (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	1079 (Assert (equal (make-vector 3 1) [1 1 1]))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1080
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1081 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1082 ;; Test bit-vector functions
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1083 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1084 (Assert (equal #010 #010))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1085 (Assert (equal #* #*))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1086 (Assert (not (equal #010 #011)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1087 (Assert (not (equal #010 #)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1088 (Assert (not (equal #110 #010)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1089 (Assert (not (equal #010 #0100)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1090 (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	1091 (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	1092 (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	1093 (Assert (equal (make-bit-vector 3 0) #*000))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1094
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1095 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1096 ;; Test buffer-local variables used as (ugh!) function parameters
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 (make-local-variable 'test-emacs-buffer-local-variable)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1099 (byte-compile
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1100 (defun test-emacs-buffer-local-parameter (test-emacs-buffer-local-variable)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1101 (setq test-emacs-buffer-local-variable nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1102 (test-emacs-buffer-local-parameter nil)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1103
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1104 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1105 ;; Test split-string
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1106 ;;-----------------------------------------------------
1425 74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent] stephent parents: 826 diff changeset	1107 ;; Keep nulls, explicit SEPARATORS
74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent] stephent parents: 826 diff changeset	1108 ;; 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	1109 ;; 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	1110 (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	1111 (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	1112 (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	1113 (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	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" "")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1116 (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	1117 (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	1118 (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	1119 (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	1120 (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	1121 (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	1122 (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	1123 ;; Omit nulls, explicit SEPARATORS
74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent] stephent parents: 826 diff changeset	1124 (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	1125 (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	1126 (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	1127 (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	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")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1130 (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	1131 (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	1132 (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	1133 (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	1134 (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	1135 (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	1136 (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	1137 ;; "Double-default" case
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") '("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 ") '("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 ") '("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") '("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 ") '("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") '("foobar")))
1425 74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent] stephent parents: 826 diff changeset	1144 ;; 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	1145 (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	1146 (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	1147 (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	1148 (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	1149 (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	1150 (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	1151 ;; 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	1152 (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	1153 '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1154 (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	1155 '("" "foo" "bar" "")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1156 (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	1157 '("" "foo" "bar" "")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1158 (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	1159 '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1160 (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	1161 '("foo" "bar" "")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1162 (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	1163 '("foobar")))
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1164
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1165 ;;-----------------------------------------------------
5035 b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1166 ;; 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	1167 ;;-----------------------------------------------------
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1168
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1169 (Assert
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1170 (equal
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1171 (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	1172 #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	1173 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	1174 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	1175 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	1176 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	1177 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	1178 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	1179 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	1180 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	1181 ?: ?\\)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1182 '("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	1183 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	1184 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	1185 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	1186 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	1187 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	1188 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	1189 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	1190 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	1191 (Assert
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1192 (equal
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1193 (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	1194 #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	1195 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	1196 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	1197 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	1198 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	1199 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	1200 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	1201 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	1202 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	1203 ?: ?\x00)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1204 '("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	1205 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	1206 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	1207 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	1208 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	1209 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	1210 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	1211 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	1212 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	1213 (Assert
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1214 (equal
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1215 (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	1216 #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	1217 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	1218 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	1219 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	1220 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	1221 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	1222 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	1223 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	1224 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	1225 '("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	1226 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	1227 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	1228 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	1229 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	1230 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	1231 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	1232 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	1233 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	1234
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1235 ;;-----------------------------------------------------
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1236 ;; Test near-text buffer functions.
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1237 ;;-----------------------------------------------------
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1238 (with-temp-buffer
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1239 (erase-buffer)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1240 (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	1241 (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	1242 (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	1243 (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	1244 (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	1245 (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	1246 (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	1247 (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	1248 (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	1249 (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	1250 (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	1251 (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	1252 (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	1253 (Assert (eq (following-char (current-buffer)) 0))
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1254 (insert "foobar")
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1255 (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	1256 (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	1257 (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	1258 (Assert (eq (following-char) 0))
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1259 (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	1260 (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	1261 (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	1262 (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	1263 (Assert (eq (following-char) ?f))
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1264 )
440 8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1265
8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1266 ;;-----------------------------------------------------
8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1267 ;; Test plist manipulation functions.
8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1268 ;;-----------------------------------------------------
8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1269 (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	1270 (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	1271 (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	1272 (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	1273 (Assert (eq t (plist-get nil t t)))
440 8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1274 (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	1275 (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	1276 (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	1277 (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	1278 (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	1279 (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	1280 (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	1281 (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	1282 (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	1283 (Assert (eq 5 (get sym 3 5)))
440 8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1284 )
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1285
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1286 (loop for obj in
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1287 (list (make-symbol "test-symbol")
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1288 "test-string"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1289 (make-extent nil nil nil)
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1290 (make-face 'test-face))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1291 do
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1292 (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	1293 (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	1294 (Assert (eq 4 (get obj ?3)) obj)
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1295 (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	1296 (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	1297 (Assert (eq t (remprop obj ?3)) obj)
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1298 (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	1299 (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	1300 (Assert (eq nil (remprop obj ?3)) obj)
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1301 (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	1302 (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	1303 (Assert (eq 5 (get obj ?3 5)) obj)
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1304 )
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1305
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1306 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1307 error "Object type has no properties"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1308 (get 2 'property))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1309
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1310 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1311 error "Object type has no settable properties"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1312 (put (current-buffer) 'property 'value))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1313
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1314 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1315 error "Object type has no removable properties"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1316 (remprop ?3 'property))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1317
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1318 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1319 error "Object type has no properties"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1320 (object-plist (symbol-function 'car)))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1321
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1322 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1323 error "Can't remove property from object"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1324 (remprop (make-extent nil nil nil) 'detachable))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1325
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1326 ;;-----------------------------------------------------
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1327 ;; Test subseq
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1328 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1329 (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	1330 (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	1331 (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	1332 (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	1333 (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	1334 (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	1335 (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	1336 (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	1337 (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	1338
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1339 (Check-Error wrong-type-argument (subseq 3 2))
1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1340 (Check-Error args-out-of-range (subseq [1 2 3] -42))
1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1341 (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	1342
5370 4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1343 (let ((string "hi there"))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1344 (Assert (equal (substring-no-properties "123" 0) "123"))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1345 (Assert (equal (substring-no-properties "1234" -3 -1) "23"))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1346 (Assert (equal (substring-no-properties "hi there" 0) "hi there"))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1347 (put-text-property 0 (length string) 'foo 'bar string)
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1348 (Assert (eq 'bar (get-text-property 0 'foo string)))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1349 (Assert (not
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1350 (get-text-property 0 'foo (substring-no-properties "hi there" 0))))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1351 (Check-Error wrong-type-argument (substring-no-properties nil 4))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1352 (Check-Error wrong-type-argument (substring-no-properties "hi there" pi))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1353 (Check-Error wrong-type-argument (substring-no-properties "hi there" 0.0)))
5360 46b53e84ea7a #'substring-no-properties: check STRING's type, get_string_range_char won't. Aidan Kehoe <kehoea@parhasard.net> parents: 5355 diff changeset	1354
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1355 ;;-----------------------------------------------------
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1356 ;; Time-related tests
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1357 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1358 (Assert (= (length (current-time-string)) 24))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1359
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1360 ;;-----------------------------------------------------
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1361 ;; format test
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1362 ;;-----------------------------------------------------
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1363 (Assert (string= (format "%d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1364 (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	1365 (Assert (string= (format "%b" 2) "10"))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1366 (Assert (string= (format "%x" 31) "1f"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1367 (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	1368 (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	1369 (Assert (string= (format "%b" 3) "11"))
826 6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1370 ;; 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	1371 ;; 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	1372 ;; is very hard.
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1373 (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	1374 (string= (format "%e" 100) "1.000000e+002")))
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1375 (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	1376 (string= (format "%E" 100) "1.000000E+002")))
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1377 (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	1378 (string= (format "%E" 100) "1.000000E+002")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1379 (Assert (string= (format "%f" 100) "100.000000"))
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1380 (Assert (string= (format "%7.3f" 12.12345) " 12.123"))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1381 (Assert (string= (format "%07.3f" 12.12345) "012.123"))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1382 (Assert (string= (format "%-7.3f" 12.12345) "12.123 "))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1383 (Assert (string= (format "%-07.3f" 12.12345) "12.123 "))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1384 (Assert (string= (format "%g" 100.0) "100"))
826 6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1385 (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	1386 (string= (format "%g" 0.000001) "1e-006")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1387 (Assert (string= (format "%g" 0.0001) "0.0001"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1388 (Assert (string= (format "%G" 100.0) "100"))
826 6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1389 (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	1390 (string= (format "%G" 0.000001) "1E-006")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1391 (Assert (string= (format "%G" 0.0001) "0.0001"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1392
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1393 (Assert (string= (format "%2$d%1$d" 10 20) "2010"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1394 (Assert (string= (format "%-d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1395 (Assert (string= (format "%-4d" 10) "10 "))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1396 (Assert (string= (format "%+d" 10) "+10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1397 (Assert (string= (format "%+d" -10) "-10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1398 (Assert (string= (format "%+4d" 10) " +10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1399 (Assert (string= (format "%+4d" -10) " -10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1400 (Assert (string= (format "% d" 10) " 10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1401 (Assert (string= (format "% d" -10) "-10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1402 (Assert (string= (format "% 4d" 10) " 10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1403 (Assert (string= (format "% 4d" -10) " -10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1404 (Assert (string= (format "%0d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1405 (Assert (string= (format "%0d" -10) "-10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1406 (Assert (string= (format "%04d" 10) "0010"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1407 (Assert (string= (format "%04d" -10) "-010"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1408 (Assert (string= (format "%*d" 4 10) " 10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1409 (Assert (string= (format "%*d" 4 -10) " -10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1410 (Assert (string= (format "%*d" -4 10) "10 "))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1411 (Assert (string= (format "%*d" -4 -10) "-10 "))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1412 (Assert (string= (format "%#d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1413 (Assert (string= (format "%#o" 8) "010"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1414 (Assert (string= (format "%#x" 16) "0x10"))
826 6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1415 (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	1416 (string= (format "%#e" 100) "1.000000e+002")))
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1417 (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	1418 (string= (format "%#E" 100) "1.000000E+002")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1419 (Assert (string= (format "%#f" 100) "100.000000"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1420 (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	1421 (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	1422 (string= (format "%#g" 0.000001) "1.00000e-006")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1423 (Assert (string= (format "%#g" 0.0001) "0.000100000"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1424 (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	1425 (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	1426 (string= (format "%#G" 0.000001) "1.00000E-006")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1427 (Assert (string= (format "%#G" 0.0001) "0.000100000"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1428 (Assert (string= (format "%.1d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1429 (Assert (string= (format "%.4d" 10) "0010"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1430 ;; Combination of `-', `+', ` ', `0', `#', `.', `*'
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1431 (Assert (string= (format "%-04d" 10) "10 "))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1432 (Assert (string= (format "%-*d" 4 10) "10 "))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1433 ;; #### Correctness of this behavior is questionable.
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1434 ;; It might be better to signal error.
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1435 (Assert (string= (format "%-*d" -4 10) "10 "))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1436 ;; These behavior is not specified.
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1437 ;; (format "%-+d" 10)
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1438 ;; (format "%- d" 10)
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1439 ;; (format "%-01d" 10)
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1440 ;; (format "%-#4x" 10)
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1441 ;; (format "%-.1d" 10)
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1442
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1443 (Assert (string= (format "%01.1d" 10) "10"))
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1444 (Assert (string= (format "%03.1d" 10) " 10"))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1445 (Assert (string= (format "%01.3d" 10) "010"))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1446 (Assert (string= (format "%1.3d" 10) "010"))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1447 (Assert (string= (format "%3.1d" 10) " 10"))
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1448
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1449 ;;; The following two tests used to use 1000 instead of 100,
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1450 ;;; 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	1451 (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	1452 (Assert (= 100 (length (format "%100f" 3.14))))
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1453
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1454 ;;; 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	1455 (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	1456 (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	1457 (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	1458 (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	1459 (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	1460 (Assert (= (read (format "%ld" most-negative-fixnum)) most-negative-fixnum))
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1461
4287 89e64783d068 [xemacs-hg @ 2007-11-27 13:51:03 by aidan] aidan parents: 2075 diff changeset	1462 ;; 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	1463 (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	1464 (Assert (eql (read (format "%.1000d" 1)) 1))
4287 89e64783d068 [xemacs-hg @ 2007-11-27 13:51:03 by aidan] aidan parents: 2075 diff changeset	1465
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1466 ;;; "%u" is undocumented, and Emacs Lisp has no unsigned type.
1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1467 ;;; 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	1468 ;;; 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	1469 ;;; 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	1470 ;;; to Emacs Lisp.
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	1471 ;;; 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	1472 (if (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	1473 (progn
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	1474 (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	1475 (Check-Error wrong-type-argument (format "%u" -1)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	1476 (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	1477 (Check-Error invalid-read-syntax (read (format "%u" -1))))
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1478
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1479 ;; Check all-completions ignore element start with space.
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1480 (Assert (not (all-completions "" '((" hidden" . "object")))))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1481 (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	1482
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1483 (let* ((literal-with-uninterned
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1484 '(first-element
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1485 [#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	1486 #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	1487 #5=#:G32970 #6=#:G32972]))
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1488 (print-readably t)
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1489 (print-gensym t)
5560 58b38d5b32d0 Implement print-circle, allowing recursive and circular structures to be read. Aidan Kehoe <kehoea@parhasard.net> parents: 5553 diff changeset	1490 (print-continuous-numbering t)
4394 cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1491 (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	1492 (awkward-regexp "#1=#")
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1493 (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	1494 printed-with-uninterned)))
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1495 (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	1496 (1+ first-match-start)))))
4580 1d11ecca9cd0 Print char table values correctly. Aidan Kehoe <kehoea@parhasard.net> parents: 4575 diff changeset	1497
1d11ecca9cd0 Print char table values correctly. Aidan Kehoe <kehoea@parhasard.net> parents: 4575 diff changeset	1498 (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	1499 (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	1500 (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	1501 (prin1-to-string char-table-with-symbol)))
4580 1d11ecca9cd0 Print char table values correctly. Aidan Kehoe <kehoea@parhasard.net> parents: 4575 diff changeset	1502 "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	1503
4608 1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1504
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1505 (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	1506 (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	1507 nil ".el")))
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1508 (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	1509 (erase-buffer)
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1510 (insert
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 ;; 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	1513 ;; 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	1514 (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	1515
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1516 ;; 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	1517 (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	1518 old-char)
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1519 (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	1520 (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	1521 (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	1522 (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	1523 (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	1524 \"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	1525
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1526 (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	1527 (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	1528 (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	1529 \"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	1530
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1531 ")
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1532 (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	1533 (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	1534 (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	1535 (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	1536 (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	1537
5576 071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1538 (labels ((cl-floor (x &optional y)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1539 (let ((q (floor x y)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1540 (list q (- x (if y (* y q) q)))))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1541 (cl-ceiling (x &optional y)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1542 (let ((res (cl-floor x y)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1543 (if (= (car (cdr res)) 0) res
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1544 (list (1+ (car res)) (- (car (cdr res)) (or y 1))))))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1545 (cl-truncate (x &optional y)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1546 (if (eq (>= x 0) (or (null y) (>= y 0)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1547 (cl-floor x y) (cl-ceiling x y)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1548 (cl-round (x &optional y)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1549 (if y
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1550 (if (and (integerp x) (integerp y))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1551 (let* ((hy (/ y 2))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1552 (res (cl-floor (+ x hy) y)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1553 (if (and (= (car (cdr res)) 0)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1554 (= (+ hy hy) y)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1555 (/= (% (car res) 2) 0))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1556 (list (1- (car res)) hy)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1557 (list (car res) (- (car (cdr res)) hy))))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1558 (let ((q (round (/ x y))))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1559 (list q (- x (* q y)))))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1560 (if (integerp x) (list x 0)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1561 (let ((q (round x)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1562 (list q (- x q))))))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1563 (Assert-rounding (first second &key
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1564 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	1565 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	1566 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	1567 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	1568 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	1569 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	1570 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	1571 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	1572 (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	1573 (floor first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1574 (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	1575 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	1576 (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	1577 (floor 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 (floor %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-floor-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 (floor 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 (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	1582 (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	1583 (floor first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1584 (format
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1585 "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	1586 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	1587 (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	1588 (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	1589 (format
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1590 "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	1591 first second))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1592 (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	1593 (ffloor first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1594 (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	1595 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	1596 (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	1597 (ffloor first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1598 (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	1599 first one-ffloor-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1600 (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	1601 (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	1602 (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	1603 (ffloor first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1604 (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	1605 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	1606 (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	1607 (ceiling first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1608 (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	1609 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	1610 (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	1611 (ceiling first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1612 (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	1613 first one-ceiling-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1614 (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	1615 (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	1616 (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	1617 (ceiling first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1618 (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	1619 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	1620 (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	1621 (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	1622 (format
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1623 "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	1624 first second))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1625 (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	1626 (fceiling first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1627 (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	1628 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	1629 (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	1630 (fceiling first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1631 (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	1632 first one-fceiling-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1633 (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	1634 (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	1635 (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	1636 (fceiling first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1637 (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	1638 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	1639 (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	1640 (round first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1641 (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	1642 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	1643 (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	1644 (round first 1)))
4686 cdabd56ce1b5 Fix various small issues with the multiple-value implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 4679 diff changeset	1645 (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	1646 first one-round-result))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1647 (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	1648 (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	1649 (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	1650 (round first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1651 (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	1652 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	1653 (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	1654 (fround first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1655 (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	1656 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	1657 (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	1658 (fround first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1659 (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	1660 first one-fround-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1661 (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	1662 (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	1663 (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	1664 (fround first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1665 (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	1666 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	1667 (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	1668 (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	1669 (format
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1670 "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	1671 first second))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1672 (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	1673 (truncate first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1674 (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	1675 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	1676 (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	1677 (truncate first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1678 (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	1679 first one-truncate-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1680 (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	1681 (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	1682 (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	1683 (truncate first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1684 (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	1685 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	1686 (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	1687 (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	1688 (format
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1689 "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	1690 first second))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1691 (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	1692 (ftruncate first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1693 (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	1694 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	1695 (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	1696 (ftruncate first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1697 (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	1698 first one-ftruncate-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1699 (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	1700 (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	1701 (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	1702 (ftruncate first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1703 (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	1704 first second two-ftruncate-result)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1705 (Assert-rounding-floating (pie ee)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1706 (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	1707 (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	1708 "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	1709 (Assert-rounding pie ee
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1710 :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	1711 :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	1712 :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	1713 :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	1714 :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	1715 :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	1716 :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	1717 :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	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) (- pie (* 1.0 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1722 :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	1723 :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	1724 :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	1725 :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	1726 (- pie (* 1.0 ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1727 (Assert-rounding pie (- ee)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1728 :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	1729 :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	1730 :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	1731 :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	1732 (- pie (* -2.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1733 :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	1734 :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	1735 :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	1736 :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	1737 (- pie (* -1.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1738 :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	1739 :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	1740 :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	1741 :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	1742 (- pie (* -1.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1743 :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	1744 :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	1745 :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	1746 :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	1747 (- pie (* -1.0 (- ee)))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1748 (Assert-rounding (- pie) ee
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1749 :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	1750 :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	1751 :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	1752 :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	1753 (- (- pie) (* -2.0 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1754 :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	1755 :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	1756 :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	1757 :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	1758 (- (- pie) (* -1.0 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1759 :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	1760 :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	1761 :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	1762 :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	1763 (- (- pie) (* -1.0 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1764 :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	1765 :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	1766 :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	1767 :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	1768 (- (- pie) (* -1.0 ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1769 (Assert-rounding (- pie) (- ee)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1770 :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	1771 :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	1772 :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	1773 :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	1774 (- (- pie) (* 1.0 (- 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 (- (- pie) -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 2 (- (- pie) (* 2 (- ee))))
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) (- (- pie) -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 2 pie-type)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1779 (- (- pie) (* 2.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1780 :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	1781 :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	1782 :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	1783 :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	1784 (- (- pie) (* 1.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1785 :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	1786 :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	1787 :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	1788 :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	1789 (- (- pie) (* 1.0 (- ee)))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1790 (Assert-rounding ee pie
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1791 :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	1792 :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	1793 :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	1794 :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	1795 :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	1796 :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	1797 :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	1798 :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	1799 :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	1800 :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	1801 :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	1802 :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	1803 :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	1804 :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	1805 :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	1806 :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	1807 (Assert-rounding ee (- pie)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1808 :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	1809 :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	1810 :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	1811 :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	1812 (- ee (* -1.0 (- pie))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1813 :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	1814 :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	1815 :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	1816 :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	1817 :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	1818 :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	1819 :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	1820 :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	1821 (- ee (* -1.0 (- pie))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1822 :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	1823 :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	1824 :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	1825 :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	1826 ;; First, two integers:
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1827 (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	1828 :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	1829 :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	1830 :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	1831 :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	1832 :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	1833 :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	1834 :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	1835 (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	1836 :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	1837 :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	1838 :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	1839 :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	1840 :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	1841 :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	1842 :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	1843 (Assert-rounding -27 8
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1844 :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	1845 :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	1846 :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	1847 :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	1848 :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	1849 :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	1850 :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	1851 :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	1852 (Assert-rounding -27 -8
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1853 :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	1854 :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	1855 :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	1856 :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	1857 :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	1858 :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	1859 :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	1860 :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	1861 (Assert-rounding 8 27
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1862 :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	1863 :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	1864 :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	1865 :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	1866 :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	1867 :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	1868 :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	1869 :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	1870 (Assert-rounding 8 -27
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1871 :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	1872 :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	1873 :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	1874 :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	1875 :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	1876 :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	1877 :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	1878 :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	1879 (Assert-rounding -8 27
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1880 :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	1881 :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	1882 :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	1883 :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	1884 :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	1885 :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	1886 :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	1887 :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	1888 (Assert-rounding -8 -27
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1889 :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	1890 :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	1891 :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	1892 :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	1893 :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	1894 :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	1895 :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	1896 :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	1897 (Assert-rounding 32 4
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1898 :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	1899 :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	1900 :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	1901 :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	1902 :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	1903 :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	1904 :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	1905 :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	1906 (Assert-rounding 32 -4
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1907 :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	1908 :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	1909 :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	1910 :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	1911 :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	1912 :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	1913 :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	1914 :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	1915 (Assert-rounding 12 9
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1916 :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	1917 :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	1918 :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	1919 :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	1920 :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	1921 :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	1922 :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	1923 :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	1924 (Assert-rounding 10 4
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1925 :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	1926 :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	1927 :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	1928 :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	1929 :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	1930 :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	1931 :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	1932 :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	1933 (Assert-rounding 14 4
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1934 :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	1935 :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	1936 :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	1937 :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	1938 :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	1939 :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	1940 :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	1941 :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	1942 ;; Now, two floats:
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1943 (Assert-rounding-floating pi e)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1944 (when (featurep 'bigfloat)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1945 (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	1946 (when (featurep 'bignum)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1947 (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	1948 "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	1949 (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	1950 :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	1951 :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	1952 :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	1953 :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	1954 :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	1955 :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	1956 :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	1957 :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	1958 :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	1959 :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	1960 :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	1961 :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	1962 :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	1963 :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	1964 :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	1965 :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	1966 (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	1967 :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	1968 :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	1969 :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	1970 :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	1971 :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	1972 :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	1973 :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	1974 :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	1975 :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	1976 :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	1977 :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	1978 :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	1979 :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	1980 :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	1981 :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	1982 :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	1983 (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	1984 :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	1985 :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	1986 :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	1987 :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	1988 :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	1989 :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	1990 :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	1991 :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	1992 :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	1993 :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	1994 :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	1995 :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	1996 :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	1997 :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	1998 :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	1999 :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	2000 ;; 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	2001 (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	2002 :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	2003 :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	2004 :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	2005 ;; 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	2006 ;; 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	2007 ;; 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	2008 ;; 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	2009 ;; 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	2010 :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	2011 :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	2012 :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	2013 :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	2014 :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	2015 :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	2016 :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	2017 :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	2018 :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	2019 :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	2020 :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	2021 :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	2022 ;; 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	2023 :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	2024 (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	2025 :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	2026 :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	2027 :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	2028 ;; 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	2029 :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	2030 :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	2031 :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	2032 :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	2033 :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	2034 :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	2035 :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	2036 :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	2037 :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	2038 :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	2039 :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	2040 :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	2041 ;; See commentary above
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2042 :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	2043 1)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2044 (when (featurep 'ratio)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2045 (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	2046 :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	2047 :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	2048 :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	2049 :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	2050 :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	2051 :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	2052 :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	2053 :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	2054 (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	2055 :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	2056 :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	2057 :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	2058 :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	2059 :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	2060 :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	2061 :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	2062 :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	2063
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2064 ;; 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	2065 ;; 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	2066 ;; 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	2067 ;; output here.
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2068
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2069 (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	2070 (let ((print-readably t))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2071 (princ first)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2072 (princ " ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2073 (princ second)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2074 (princ " :one-floor-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 (floor first))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2076 (princ " :two-floor-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 (floor first second))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2078 (princ " :one-ffloor-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 (ffloor first))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2080 (princ " :two-ffloor-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 (ffloor first second))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2082 (princ " :one-ceiling-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 (ceiling first))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2084 (princ " :two-ceiling-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 (ceiling first second))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2086 (princ " :one-fceiling-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2087 (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	2088 (princ " :two-fceiling-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2089 (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	2090 (princ " :one-round-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2091 (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	2092 (princ " :two-round-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2093 (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	2094 (princ " :one-fround-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2095 (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	2096 (princ " :two-fround-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2097 (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	2098 (princ " :one-truncate-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2099 (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	2100 (princ " :two-truncate-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2101 (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	2102 (princ " :one-ftruncate-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2103 (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	2104 (princ " :two-ftruncate-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2105 (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	2106
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2107 ;; Multiple value tests.
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2108
5576 071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2109 (labels ((foo (x y)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2110 (floor (+ x y) y))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2111 (foo-zero (x y)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2112 (values (floor (+ x y) y)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2113 (multiple-value-function-returning-t ()
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2114 (values t pi e degrees-to-radians radians-to-degrees))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2115 (multiple-value-function-returning-nil ()
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2116 (values nil pi e radians-to-degrees degrees-to-radians))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2117 (function-throwing-multiple-values ()
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2118 (let* ((listing '(0 3 4 nil "string" symbol))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2119 (tail listing)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2120 elt)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2121 (while t
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2122 (setq tail (cdr listing)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2123 elt (car listing)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2124 listing tail)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2125 (when (null elt)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2126 (throw 'VoN61Lo4Y (multiple-value-function-returning-t)))))))
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2127 (Assert
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2128 (= (+ (floor 5 3) (floor 19 4)) (+ 1 4) 5)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2129 "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	2130 (Assert
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2131 (= 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	2132 "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	2133 (Assert
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2134 (= 1 (length (multiple-value-list
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2135 (foo-zero 400 (1+ most-positive-fixnum)))))
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2136 "Checking multiple values are discarded correctly when forced")
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2137 (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	2138 (Assert (equal '(-1 1)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2139 (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	2140 "Checking #'multiple-value-list gives a sane result")
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2141 (let ((ey 40000)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2142 (bee "this is a string")
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2143 (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	2144 (Assert (equal
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2145 (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	2146 (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	2147 "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	2148 (Assert (equal
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2149 (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	2150 (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	2151 "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	2152 (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	2153 "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	2154 (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	2155 "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	2156 (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	2157 "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	2158 (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	2159 (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	2160 "Checking #'multiple-value-prog1 passes back multiple values")
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2161 (multiple-value-bind (floored remainder this-is-nil)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2162 (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	2163 (Assert (= floored 3)
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2164 "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	2165 (Assert (eql remainder (- pi 3.0))
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2166 "Checking remainder bound correctly")
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2167 (Assert (null this-is-nil)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2168 "Checking trailing arg bound but nil"))
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2169 (let ((ey 40000)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2170 (bee "this is a string")
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2171 (cee #s(hash-table size 256 data (969 ?\xF9))))
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2172 (multiple-value-setq (ey bee cee)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2173 (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	2174 (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	2175 (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	2176 (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	2177 (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	2178 "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	2179 (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	2180 "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	2181 (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	2182 "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	2183 (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	2184 (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	2185 "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	2186 (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	2187 (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	2188 "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	2189 (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	2190 (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	2191 "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	2192 (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	2193 (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	2194 "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	2195 (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	2196 (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	2197 "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	2198 (Assert (= 1 (length (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2199 (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	2200 "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	2201 (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	2202 (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2203 (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	2204 "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	2205 (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	2206 (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	2207 "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	2208 (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	2209 (multiple-value-prog1
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2210 (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	2211 "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	2212 (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	2213 (multiple-value-list
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2214 (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	2215 (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	2216 (multiple-value-list
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2217 (loop
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2218 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	2219 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	2220 (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	2221 "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	2222 (Assert
cdabd56ce1b5 Fix various small issues with the multiple-value implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 4679 diff changeset	2223 (null (or))
cdabd56ce1b5 Fix various small issues with the multiple-value implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 4679 diff changeset	2224 "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	2225 (Assert (eq t (and))
4686 cdabd56ce1b5 Fix various small issues with the multiple-value implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 4679 diff changeset	2226 "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	2227 (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	2228 (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	2229 (* 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	2230 "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	2231
4792 95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2232 ;; #'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	2233 (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	2234 (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	2235 (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	2236 (+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	2237 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	2238 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	2239 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	2240 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	2241 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	2242
5188 000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2243 (macrolet
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2244 ((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	2245 (let (res)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2246 (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	2247 (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	2248 (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	2249 (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	2250 (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	2251 ,(quote-maybe y))) res)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2252 (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	2253 ,(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	2254 (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	2255 (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	2256 res))))
5188 000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2257 (cons 'progn (nreverse res))))
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2258 (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	2259 (let (res)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2260 (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	2261 (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	2262 (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	2263 (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	2264 ,(quote-maybe y)))) res)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2265 (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	2266 ,(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	2267 (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	2268 (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	2269 `(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	2270 (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	2271 ,@(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	2272 (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	2273 (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	2274 (equalp-equal-list-tests
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2275 `(,@(when (featurep 'bignum)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2276 (read "((111111111111111111111111111111111111111111111111111
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2277 111111111111111111111111111111111111111111111111111.0))"))
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2278 (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	2279 (21845 #b101010101010101 #x5555)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2280 (1.5 1.500000000000000000000000000000000000000000000000000000000
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2281 ,@(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	2282 ;; 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	2283 ;;(-12345678901234567890123457890123457890123457890123457890123457890
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2284 ;; -12345678901234567890123457890123457890123457890123457890123457890.0)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2285 (-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	2286 (equalp-diff-list-tests
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2287 `(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	2288 ,@(when (featurep 'bignum)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2289 (read "(5555555555555555555555555555555555555
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2290 -5555555555555555555555555555555555555)"))
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2291 -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	2292 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	2293 ,@(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	2294 55555555555555555555555555555555555555555/2718281828459045
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2295 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	2296 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	2297
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	2298 (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	2299 "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	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 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	2302 "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	2303 (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	2304 "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	2305 ;; 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	2306 (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	2307 "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	2308 (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	2309 "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	2310 "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	2311 (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	2312 "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	2313 "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	2314 (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	2315 "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	2316 (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	2317 "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	2318 (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	2319 "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	2320 (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	2321 (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	2322 "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	2323 (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	2324 "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	2325 (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	2326 (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	2327 (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	2328 "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	2329 (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	2330 [?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	2331 (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	2332 "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	2333 (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	2334 (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	2335 "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	2336 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	2337 (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	2338 (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	2339 "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	2340 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	2341 (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	2342 (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	2343 "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	2344 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	2345 (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	2346 "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	2347 (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	2348 "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	2349 (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	2350 "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	2351 (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	2352 "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	2353 (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	2354 (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	2355 (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	2356 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	2357 "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	2358 (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	2359 (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	2360 (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	2361 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	2362 "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	2363 (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	2364 (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	2365 (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	2366 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	2367 "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	2368
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2369 ;; 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	2370 ;;
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2371 ;; 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	2372 ;;
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2373 ;; 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	2374 ;; 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	2375 ;; 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	2376 ;; 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	2377 ;; 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	2378 ;; 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	2379
4795 084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2380 (loop
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2381 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	2382 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	2383 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	2384 do
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2385 (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	2386 (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	2387 (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	2388 (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	2389 (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	2390 (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	2391 (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	2392 (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	2393
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2394 (loop
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2395 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	2396 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	2397 (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	2398
4885 6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2399 ;; #'member, #'assoc tests.
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2400
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2401 (when (featurep 'bignum)
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2402 (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	2403 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	2404 (assoc*-list (loop
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2405 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	2406 collect (cons elt (random))))
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2407 (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	2408 hashed-bignum)
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2409 (macrolet
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2410 ((1+most-positive-fixnum ()
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2411 (1+ most-positive-fixnum))
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2412 (1-most-negative-fixnum ()
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2413 (1- most-negative-fixnum))
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2414 (*-2-most-positive-fixnum ()
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2415 (* 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	2416 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2417 (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	2418 (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	2419 "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	2420 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2421 (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	2422 (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	2423 "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	2424 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2425 (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	2426 (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	2427 "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	2428 (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	2429 "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	2430 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2431 (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	2432 (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	2433 "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	2434 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2435 (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	2436 (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	2437 "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	2438 (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	2439 (gensym) hashing)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2440 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2441 (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	2442 (gethash hashed-bignum hashing))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2443 "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	2444
5700 37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2445 ;; #'subsetp tests.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2446 ;; Return non-nil if every element of LIST1 also appears in LIST2.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2447 ;; A couple of non-nondegenerate false cases.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2448 (Assert (not (subsetp (list ?a ?b) (list ?c ?d))))
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2449 (Assert (not (subsetp (list ?a ?b) (list ?b ?c ?d))))
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2450 ;; Next five thanks to Steven and Benson Mitchell on XEmacs Beta
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2451 ;; <50D16FF7.4090708@bnin.net>.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2452 ;; Two non-degenerate true cases.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2453 (Assert (subsetp (list ?a) (list ?a ?b ?c ?d)))
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2454 (Assert (subsetp (list ?a ?b) (list ?a ?b ?c ?d)))
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2455 ;; The three degenerate cases involving nil.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2456 (Assert (not (subsetp (list ?a) nil)))
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2457 (Assert (subsetp nil (list ?a ?b ?c ?d)))
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2458 (Assert (subsetp nil nil))
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2459 ;; #### We should also test the keywords.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2460 ;; #### We should also test the error conditions.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2461
5241 d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2462 ;;
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2463 (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	2464 (Check-Error
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2465 invalid-state
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2466 (let ((str "aaaaaaaaaaaaa")
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2467 (called 0)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2468 modified)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2469 (reduce #'+ str
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2470 :key #'(lambda (object)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2471 (prog1
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2472 object
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2473 (incf called)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2474 (or modified
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2475 (and (> called 5)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2476 (setq modified
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2477 (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	2478
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2479 (Assert
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2480 (eql 55
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2481 (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	2482 (called 0)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2483 modified)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2484 (reduce #'+
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2485 sequence
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2486 :key
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2487 #'(lambda (object) (prog1
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2488 object
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2489 (incf called)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2490 (and (eql called 5)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2491 (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	2492 (garbage-collect))))))
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2493 "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	2494
5244 04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2495 (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	2496 `(((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	2497 ((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	2498 "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	2499
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2500 (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	2501 `(((mswindows) . [nothing])
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2502 ((tty) . [string :data " "]))
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2503 'image t)))
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2504 "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	2505
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2506 (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	2507 (canonicalize-inst-list
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2508 `(((,(gensym)) . [nothing])
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2509 ((tty) . [string :data " "]))
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2510 'image))
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2511
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2512 (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	2513 (canonicalize-inst-list
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2514 `(((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	2515 ((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	2516
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2517 ;; 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	2518 ;; 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	2519 ;; 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	2520 ;; 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	2521 ;; 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	2522 ;; 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	2523
5243 808131ba4a57 Print symbols with ratio-like names and the associated ratios distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5241 diff changeset	2524 (when (featurep 'ratio)
808131ba4a57 Print symbols with ratio-like names and the associated ratios distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5241 diff changeset	2525 (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	2526 "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	2527 (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	2528 "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	2529
5283 be436ac36ba4 Don't share a counter when checking for circularity, list_merge(). Aidan Kehoe <kehoea@parhasard.net> parents: 5244 diff changeset	2530 (let* ((count 0)
be436ac36ba4 Don't share a counter when checking for circularity, list_merge(). Aidan Kehoe <kehoea@parhasard.net> parents: 5244 diff changeset	2531 (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	2532 (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	2533 (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	2534 "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	2535
5576 071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2536 (labels ((list-nreverse (list)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2537 (do ((list1 list (cdr list1))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2538 (list2 nil (prog1 list1 (setcdr list1 list2))))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2539 ((atom list1) list2))))
5300 9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2540 (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	2541 (characters (mapcan #'(lambda (integer)
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2542 (if (char-int-p integer)
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2543 (list (int-char integer)))) integers))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2544 (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	2545 (bits (mapcar fourth-bit integers))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2546 (vector (vconcat integers))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2547 (string (concat characters))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2548 (bit-vector (bvconcat bits)))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2549 (Assert (equal (reverse vector)
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2550 (vconcat (list-nreverse (copy-list integers)))))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2551 (Assert (eq vector (nreverse vector)))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2552 (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	2553 (Assert (equal (reverse string)
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2554 (concat (list-nreverse (copy-list characters)))))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2555 (Assert (eq string (nreverse string)))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2556 (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	2557 (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	2558 (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	2559 (Assert (not (equal bit-vector
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2560 (mapcar fourth-bit
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2561 (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	2562
5307 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 (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	2564 (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	2565 (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	2566 (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	2567 'make-bit-vector))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2568 (Check-Error wrong-type-argument (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	2569 'ignore))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2570 (Check-Error wrong-type-argument (make-string ?a ?a))
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 (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	2572 (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	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 (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	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 (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	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 (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	2579 (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	2580 (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	2581 (stop-profiling)
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2582 (Check-Error wrong-type-argument (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	2583 (stop-profiling)
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2584 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2585 (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	2586 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2587 (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	2588 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2589 (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	2590 (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	2591 (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	2592 (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	2593 (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	2594 (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	2595 (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	2596 (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	2597 (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	2598 (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	2599 (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	2600 (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	2601 (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	2602 (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	2603 (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	2604 (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	2605 (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	2606 (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	2607 (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	2608 (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	2609 (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	2610 (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	2611 (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	2612 (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	2613 (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	2614 (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	2615 (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	2616
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2617 (when (featurep 'bignum)
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2618 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2619 (self-insert-command (* 2 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 (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	2622 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2623 (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	2624 (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	2625 (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	2626 (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	2627 (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	2628 (1+ most-positive-fixnum)))
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 (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	2631 #x10000))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2632 (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	2633 (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	2634 (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	2635 (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	2636 (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	2637 (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	2638 (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	2639 (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	2640 (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	2641 (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	2642 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2643 (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	2644 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2645 (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	2646 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2647 (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	2648 (when (featurep 'xbm)
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2649 (Check-Error-Message
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2650 invalid-argument
5736 3192994c49ca Convert C (un)signed long long values to bignums properly. Jerry James <james@xemacs.org> parents: 5700 diff changeset	2651 "^Height must be a natural number"
5307 c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2652 (set-face-background-pixmap
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2653 'left-margin
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2654 `[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	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 (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	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 (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	2659 (stop-profiling)
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2660 (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	2661 ;; 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	2662 ;; 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	2663 ;; 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	2664 (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	2665 (stop-profiling)
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2666 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2667 (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	2668 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2669 (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	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 (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	2672 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2673 (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	2674 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2675 (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	2676 (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	2677 (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	2678 (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	2679 (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	2680 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2681 (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	2682 (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	2683 (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	2684 (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	2685 (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	2686 (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	2687 (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	2688 (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	2689 (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	2690 (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	2691 (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	2692 (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	2693 (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	2694 (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	2695 (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	2696 (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	2697 (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	2698 (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	2699 (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	2700 :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	2701 (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	2702 (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	2703 :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	2704 (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	2705 (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	2706 :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	2707 (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	2708 (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	2709 :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	2710
5323 f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2711 (symbol-macrolet
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2712 ((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	2713 (let ((list
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2714 ;; 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	2715 ;; is longer than that.
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2716 (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	2717 (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	2718 (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	2719 (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	2720 (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	2721 (item 'cons))
5347 fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2722 (macrolet
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2723 ((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	2724 (cons
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2725 'progn
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2726 (mapcan
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2727 #'(lambda (function)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2728 `((Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2729 (,function item list
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2730 :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	2731 :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	2732 (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	2733 (,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	2734 :end list-length))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2735 (Check-Error 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	2736 (,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	2737 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2738 (,function item vector
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2739 :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	2740 :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	2741 (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	2742 (,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	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 item vector
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2745 :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	2746 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2747 (,function item bit-vector
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2748 :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	2749 :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	2750 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2751 (,function 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	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 item bit-vector
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2754 :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	2755 (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	2756 (,function item string
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2757 :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	2758 :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	2759 (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	2760 (,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	2761 (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	2762 (,function item string
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2763 :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	2764 functions)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2765 (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	2766 (cons
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2767 'progn
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2768 (mapcan
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2769 #'(lambda (function)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2770 `((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	2771 (,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	2772 :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	2773 :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	2774 (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	2775 (,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	2776 :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	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 :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	2780 (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	2781 (,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	2782 :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	2783 :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	2784 (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	2785 (,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	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 vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2788 :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	2789 (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	2790 (,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	2791 :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	2792 :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	2793 (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	2794 (,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	2795 :start -1))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2796 (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	2797 (,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	2798 :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	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 string)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2801 :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	2802 :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	2803 (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	2804 (,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	2805 (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	2806 (,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	2807 :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	2808 functions)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2809 (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	2810 (cons
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2811 'progn
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2812 (mapcan
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2813 #'(lambda (function)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2814 `((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	2815 (,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	2816 (copy-sequence list)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2817 :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	2818 :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	2819 (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	2820 (,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	2821 (copy-sequence list)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2822 :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	2823 (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	2824 (,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	2825 (copy-sequence list)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2826 :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	2827 (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	2828 (,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	2829 (copy-sequence vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2830 :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	2831 :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	2832 (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	2833 (,function
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2834 (copy-sequence vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2835 (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	2836 (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	2837 (,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	2838 (copy-sequence vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2839 :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	2840 (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	2841 (,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	2842 (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	2843 :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	2844 :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	2845 (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	2846 (,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	2847 (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	2848 :start1 -1))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2849 (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	2850 (,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	2851 (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	2852 :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	2853 (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	2854 (,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	2855 (copy-sequence string)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2856 :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	2857 :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	2858 (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	2859 (,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	2860 (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	2861 (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	2862 (,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	2863 (copy-sequence string)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2864 :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	2865 functions))))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2866 (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	2867 reduce)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2868 (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	2869 (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	2870
5336 287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2871 (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	2872 (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	2873 (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	2874 #'(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	2875 (string (map 'string
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2876 #'(lambda (object) (or (and (fixnump object)
5772 cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	2877 (int-char object))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	2878 (decode-char 'ucs #x20ac)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	2879 ?\x20))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	2880 list))
5336 287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2881 (gensym (gensym)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2882 (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	2883 (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	2884 (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	2885 (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	2886 (loop
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2887 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	2888 do
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2889 (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	2890 (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	2891 (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	2892 (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	2893 (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	2894 (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	2895 (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	2896 ;; 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	2897 (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	2898
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2899 ;; Test concatenate.
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2900 (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	2901 (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	2902 (subseq list 4))))
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2903 (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	2904 (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	2905 (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	2906 (append string nil))))
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2907 (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	2908 (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	2909 (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	2910 (subseq bit-vector 0 4)
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2911 (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	2912
5353 38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2913 ;;-----------------------------------------------------
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2914 ;; Test `block', `return-from'
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2915 ;;-----------------------------------------------------
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2916 (Assert (eql 1 (block outer
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2917 (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	2918 (block outer (outtahere 1)))
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2919 2))
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2920 "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	2921
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2922 ;; 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	2923 ;; 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	2924 ;; 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	2925 ;; CLTL2, whence the following test:
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2926
5576 071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2927 (labels ((needs-lexical-context (first second third)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2928 (if (eql 0 first)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2929 (funcall second)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2930 (block awkward
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2931 (+ 5 (needs-lexical-context
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2932 (1- first)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2933 third
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2934 #'(lambda () (return-from awkward 0)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2935 first)))))
5595 391d809fa4e9 Update tests that have started failing because of changed design decisions. Aidan Kehoe <kehoea@parhasard.net> parents: 5576 diff changeset	2936 (Known-Bug-Expect-Failure
391d809fa4e9 Update tests that have started failing because of changed design decisions. Aidan Kehoe <kehoea@parhasard.net> parents: 5576 diff changeset	2937 (Assert (eql 0 (needs-lexical-context 2 nil nil))
391d809fa4e9 Update tests that have started failing because of changed design decisions. Aidan Kehoe <kehoea@parhasard.net> parents: 5576 diff changeset	2938 "the function special operator doesn't create a lexical context.")))
5353 38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2939
5642 5bda701e9e7c Be more careful about non-quoted-symbol TAGs, #'byte-compile-catch Aidan Kehoe <kehoea@parhasard.net> parents: 5595 diff changeset	2940 (Assert (eql 10 (catch ':keyword (+ (catch :keyword (throw :keyword 9)) 1)))
5bda701e9e7c Be more careful about non-quoted-symbol TAGs, #'byte-compile-catch Aidan Kehoe <kehoea@parhasard.net> parents: 5595 diff changeset	2941 "checking `byte-compile-catch' doesn't strip keyword TAGs")
5bda701e9e7c Be more careful about non-quoted-symbol TAGs, #'byte-compile-catch Aidan Kehoe <kehoea@parhasard.net> parents: 5595 diff changeset	2942
5462 97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2943 ;; Test symbol-macrolet with symbols with identical string names.
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2944
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2945 (macrolet
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2946 ((test-symbol-macrolet ()
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2947 (let* ((symbol 'my-symbol)
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2948 (copy-symbol (copy-symbol symbol))
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2949 (third (copy-symbol copy-symbol)))
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2950 `(symbol-macrolet ((,symbol [symbol expansion])
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2951 (,copy-symbol [copy expansion])
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2952 (,third [third expansion]))
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2953 (list ,symbol ,copy-symbol ,third)))))
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2954 (Assert (equal '([symbol expansion] [copy expansion] [third expansion])
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2955 (test-symbol-macrolet))))
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2956
5550 b908c7265a2b Add the #'apply-partially API, as used by GNU. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	2957 ;; Basic tests of #'apply-partially.
b908c7265a2b Add the #'apply-partially API, as used by GNU. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	2958 (let* ((four 4)
b908c7265a2b Add the #'apply-partially API, as used by GNU. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	2959 (times-four (apply-partially '* four))
5553 62edcc6a11ec Add an assertion about argument order to #'apply-partially compiler macro Aidan Kehoe <kehoea@parhasard.net> parents: 5550 diff changeset	2960 (plus-twelve (apply-partially '+ 6 (* 3 2)))
62edcc6a11ec Add an assertion about argument order to #'apply-partially compiler macro Aidan Kehoe <kehoea@parhasard.net> parents: 5550 diff changeset	2961 (construct-list (apply-partially 'list (incf four) (incf four)
5737 165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2962 (incf four)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2963 (list-and-multiply
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2964 (apply-partially #'(lambda (a b c d &optional e)
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2965 (cons (apply #'+ a b c d (if e (list e)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2966 (list* a b c d e)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2967 ;; Constant arguments -> function can be
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2968 ;; constructed at compile time
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2969 1 2 3))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2970 (list-and-four
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2971 (apply-partially #'(lambda (a b c d &optional e)
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2972 (cons (apply #'+ a b c d (if e (list e)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2973 (list* a b c d e)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2974 ;; Not constant arguments -> function constructed
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2975 ;; at runtime.
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2976 1 2 four)))
5550 b908c7265a2b Add the #'apply-partially API, as used by GNU. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	2977 (Assert (eql (funcall times-four 6) 24))
b908c7265a2b Add the #'apply-partially API, as used by GNU. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	2978 (Assert (eql (funcall times-four 4 4) 64))
b908c7265a2b Add the #'apply-partially API, as used by GNU. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	2979 (Assert (eql (funcall plus-twelve (funcall times-four 4) 4 4) 36))
5553 62edcc6a11ec Add an assertion about argument order to #'apply-partially compiler macro Aidan Kehoe <kehoea@parhasard.net> parents: 5550 diff changeset	2980 (Check-Error wrong-number-of-arguments (apply-partially))
5737 165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2981 (Assert (equal (funcall construct-list) '(5 6 7)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2982 (Assert (equal (funcall list-and-multiply 5 6) '(17 1 2 3 5 . 6)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2983 (Assert (equal (funcall list-and-multiply 7) '(13 1 2 3 7)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2984 (Check-Error wrong-number-of-arguments
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2985 (funcall list-and-multiply 7 8 9 10))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2986 (Assert (equal (funcall list-and-four 5 6) '(21 1 2 7 5 . 6)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2987 (Assert (equal (funcall list-and-four 7) '(17 1 2 7 7)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2988 (Check-Error wrong-number-of-arguments
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2989 (funcall list-and-four 7 8 9 10)))
5550 b908c7265a2b Add the #'apply-partially API, as used by GNU. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	2990
5574 d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	2991 ;; Test labels and inlining.
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	2992 (labels
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	2993 ((+ (&rest arguments)
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	2994 ;; Shades of Java, hah.
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	2995 (mapconcat #'prin1-to-string arguments ", "))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	2996 (print-with-commas (stream one two three four five)
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	2997 (princ (+ one two three four five) stream))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	2998 (bookend (open close &rest arguments)
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	2999 (refer-to-bookend (concat open (apply #'+ arguments) close)))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3000 (refer-to-bookend (string)
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3001 (bookend "[" "]" string "hello" "there")))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3002 (declare (inline + print-with-commas bookend refer-to-bookend))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3003 (macrolet
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3004 ((with-first-arguments (&optional form)
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3005 (append form (list 1 [hi there] 40 "this is a string" pi)))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3006 (with-second-arguments (&optional form)
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3007 (append form (list pi e ''hello ''there [40 50 60])))
5658 289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3008 (with-both-arguments (&optional form &environment env)
5574 d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3009 (append form
5658 289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3010 (macroexpand '(with-first-arguments) env)
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3011 (macroexpand '(with-second-arguments) env))))
5574 d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3012
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3013 (with-temp-buffer
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3014 (Assert
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3015 (equal
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3016 (mapconcat #'prin1-to-string (with-first-arguments (list)) ", ")
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3017 (with-first-arguments (print-with-commas (current-buffer))))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3018 "checking print-with-commas gives the expected result")
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3019 (Assert
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3020 (or
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3021 (not (compiled-function-p (indirect-function #'print-with-commas)))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3022 (notany #'compiled-function-p
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3023 (compiled-function-constants
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3024 (indirect-function #'print-with-commas))))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3025 "checking the label + was inlined correctly")
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3026 (insert ", ")
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3027 ;; This call to + will be inline in compiled code, but there's
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3028 ;; no easy way for us to check that:
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3029 (Assert (null (insert (with-second-arguments (+)))))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3030 (Assert (equal
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3031 (mapconcat #'prin1-to-string (with-both-arguments (list)) ", ")
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3032 (buffer-string))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3033 "checking the buffer contents are as expected at the end.")
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3034 (Assert (not (funcall (intern "eq") #'bookend #'refer-to-bookend))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3035 "checking two mutually recursive functions compiled OK"))))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3036
5658 289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3037 ;; Test macroexpand's handling of the ENVIRONMENT argument. We augmented it
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3038 ;; quietly for about four months, and this was incorrect.
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3039
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3040 (Check-Error
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3041 void-variable
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3042 (macrolet
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3043 ((with-first-arguments (&optional form)
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3044 (append form (list 1 [hi there] 40 "this is a string" pi)))
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3045 (with-second-arguments (&optional form)
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3046 (append form (list pi e ''hello ''there [40 50 60])))
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3047 (with-both-arguments (&optional form)
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3048 (append form
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3049 (macroexpand '(with-first-arguments))
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3050 (macroexpand '(with-second-arguments)))))
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3051 (with-both-arguments (list))))
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3052
5769 ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3053 ;; Test arithmetic comparisons of markers and operations on markers. Most
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3054 ;; relevant with Mule, but also worth doing on non-Mule.
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3055 (let ((character (if (featurep 'mule) (decode-char 'ucs #x20ac) ?\xff))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3056 (translation (make-char-table 'generic))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3057 markers fixnums)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3058 (macrolet
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3059 ((Assert-arith-equivalences (markers context)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3060 `(progn
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3061 (Assert (apply #'> markers)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3062 ,(concat "checking #'> correct with long arguments list, "
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3063 context))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3064 (Assert 0 ,context)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3065 (Assert (apply #'< (reverse markers))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3066 ,(concat "checking #'< correct with long arguments list, "
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3067 context))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3068 (map-plist #'(lambda (object1 object2)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3069 (Assert (> object1 object2)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3070 ,(concat
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3071 "checking markers correctly ordered, >, "
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3072 context))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3073 (Assert (< object2 object1)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3074 ,(concat
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3075 "checking markers correctly ordered, <, "
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3076 context)))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3077 markers)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3078 ;; OK, so up to this point there has been no need for byte-char
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3079 ;; conversion. The following requires it, though:
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3080 (map-plist #'(lambda (object1 object2)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3081 (Assert
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3082 (= (max object1 object2) object1)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3083 ,(concat
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3084 "checking max correct, two markers, " context))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3085 (Assert
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3086 (= (min object1 object2) object2)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3087 ,(concat
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3088 "checking min, correct, two markers, " context))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3089 ;; It is probably reasonable to change this design
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3090 ;; decision.
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3091 (Assert
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3092 (fixnump (max object1 object2))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3093 ,(concat
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3094 "checking fixnum conversion as documented, max, "
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3095 context))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3096 (Assert
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3097 (fixnump (min object1 object2))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3098 ,(concat
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3099 "checking fixnum conversion as documented, min, "
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3100 context)))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3101 markers))))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3102 (with-temp-buffer
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3103 (loop for ii from 0 to 100
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3104 do (progn
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3105 (insert " " character " " character " " character " "
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3106 character "\n")
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3107 (insert character)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3108 (push (copy-marker (1- (point)) t) markers)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3109 (insert ?\x20)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3110 (push (copy-marker (1- (point)) t) markers)))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3111 (Assert-arith-equivalences markers "with Euro sign")
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3112 ;; Save the markers as fixnum character positions:
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3113 (setq fixnums (mapcar #'marker-position markers))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3114 ;; Check that the equivalences work with the fixnums, while we
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3115 ;; have them:
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3116 (Assert-arith-equivalences fixnums "fixnums, with Euro sign")
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3117 ;; Now, transform the characters that may be problematic to ASCII,
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3118 ;; check our equivalences still hold.
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3119 (put-char-table character ?\x7f translation)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3120 (translate-region (point-min) (point-max) translation)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3121 ;; Sigh, restore the markers #### shouldn't the insertion and
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3122 ;; deletion code do this?!
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3123 (map nil #'set-marker markers fixnums)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3124 (Assert-arith-equivalences markers "without Euro sign")
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3125 ;; Restore the problematic character.
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3126 (put-char-table ?\x7f character translation)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3127 (translate-region (point-min) (point-max) translation)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3128 (map nil #'set-marker markers fixnums)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3129 (Assert-arith-equivalences markers "with Euro sign restored"))))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3130
5772 cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3131 ;;-----------------------------------------------------
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3132 ;; Test #'write-sequence and friends.
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3133 ;;-----------------------------------------------------
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3134
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3135 (macrolet
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3136 ((Assert-write-results (function context &key short-string long-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3137 sequences-too output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3138 clear-output get-last-output)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3139 "Check correct output in CONTEXT for `write-sequence' and friends."
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3140 (let* ((short-bit-vector (map 'bit-vector #'logand short-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3141 (make-circular-list 1 1)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3142 (long-bit-vector (map 'bit-vector #'logand long-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3143 (make-circular-list 1 1)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3144 (short-bit-vector-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3145 (map #'string #'int-char short-bit-vector))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3146 (long-bit-vector-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3147 (map #'string #'int-char long-bit-vector)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3148 `(progn
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3149 (,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3150 (,function ,short-string ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3151 (Assert (equal ,short-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3152 (,get-last-output ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3153 ,(length short-string)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3154 ,(format "checking %s with short string, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3155 function context))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3156 ,@(when sequences-too
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3157 `((,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3158 (,function ,(vconcat short-string) ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3159 (Assert (equal ,short-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3160 (,get-last-output ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3161 ,(length short-string)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3162 ,(format "checking %s with short vector, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3163 function context))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3164 (,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3165 (,function ',(append short-string nil) ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3166 (Assert (equal ,short-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3167 (,get-last-output ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3168 ,(length short-string)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3169 ,(format "checking %s with short list, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3170 function context))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3171 (,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3172 (,function ,short-bit-vector ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3173 (Assert (equal ,short-bit-vector-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3174 (,get-last-output
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3175 ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3176 ,(length short-bit-vector-string)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3177 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3178 "checking %s with short bit-vector, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3179 function context))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3180 (,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3181 (,function ,long-bit-vector ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3182 (Assert (equal ,long-bit-vector-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3183 (,get-last-output
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3184 ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3185 ,(length long-bit-vector-string)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3186 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3187 "checking %s with long bit-vector, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3188 function context))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3189 ,(cons
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3190 'progn
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3191 (loop
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3192 for (subseq-start subseq-end description)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3193 in `((0 ,(length short-string) "trivial range")
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3194 (4 7 "harder range"))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3195 nconc
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3196 `((,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3197 (,function ,short-string ,output-stream :start ,subseq-start
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3198 :end ,subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3199 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3200 (equal ,(subseq short-string subseq-start subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3201 (,get-last-output ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3202 ,(- subseq-end subseq-start)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3203 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3204 "checking %s with short string, %s, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3205 function context description))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3206 ,@(when sequences-too
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3207 `((,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3208 (,function ,(vconcat short-string) ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3209 :start ,subseq-start :end ,subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3210 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3211 (equal ,(subseq short-string subseq-start subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3212 (,get-last-output ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3213 ,(- subseq-end subseq-start)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3214 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3215 "checking %s with short vector, %s, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3216 function context description))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3217 (,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3218 (,function ',(append short-string nil) ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3219 :start ,subseq-start :end ,subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3220 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3221 (equal ,(subseq short-string subseq-start subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3222 (,get-last-output
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3223 ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3224 ,(- subseq-end subseq-start )))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3225 ,(format "checking %s with short list, %s, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3226 function context description))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3227 (,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3228 (,function ,short-bit-vector ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3229 :start ,subseq-start :end ,subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3230 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3231 (equal ,(subseq short-bit-vector-string subseq-start
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3232 subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3233 (,get-last-output ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3234 ,(- subseq-end subseq-start)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3235 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3236 "checking %s with short bit-vector, %s, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3237 function context description)))))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3238 ,(cons
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3239 'progn
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3240 (loop
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3241 for (subseq-start subseq-end description)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3242 in `((0 ,(length long-string) "trivial range")
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3243 (4 90 "harder range"))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3244 nconc
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3245 `((,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3246 (,function ,long-string ,output-stream :start ,subseq-start
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3247 :end ,subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3248 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3249 (equal ,(subseq long-string subseq-start subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3250 (,get-last-output ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3251 ,(- subseq-end subseq-start)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3252 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3253 "checking %s with long string, %s, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3254 function context description))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3255 ,@(when sequences-too
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3256 `((,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3257 (,function ,(vconcat long-string) ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3258 :start ,subseq-start :end ,subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3259 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3260 (equal ,(subseq long-string subseq-start subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3261 (,get-last-output
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3262 ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3263 ,(- subseq-end subseq-start)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3264 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3265 "checking %s with long vector, %s, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3266 function context description))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3267 (,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3268 (,function ',(append long-string nil) ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3269 :start ,subseq-start :end ,subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3270 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3271 (equal ,(subseq long-string subseq-start subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3272 (,get-last-output ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3273 ,(- subseq-end subseq-start)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3274 ,(format "checking %s with long list, %s, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3275 function context description))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3276 (,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3277 (,function ,long-bit-vector ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3278 :start ,subseq-start :end ,subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3279 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3280 (equal ,(subseq long-bit-vector-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3281 subseq-start subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3282 (,get-last-output
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3283 ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3284 ,(- subseq-end subseq-start)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3285 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3286 "checking %s with long bit-vector, %s, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3287 function context description)))))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3288 (,clear-output ,output-stream))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3289 (test-write-string (function &key sequences-too worry-about-newline)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3290 (let* ((short-string "hello there")
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3291 (long-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3292 (decode-coding-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3293 (concat
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3294 "\xd8\xb3\xd9\x84\xd8\xa7\xd9\x85 \xd8\xb9\xd9\x84"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3295 "\xdb\x8c\xda\xa9\xd9\x85\x2c \xd8\xa7\xd8\xb3\xd9"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3296 "\x85 \xd9\x85\xd9\x86 \xd8\xa7\xdb\x8c\xd8\xaf\xd9"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3297 "\x86 \xda\xa9\xdb\x8c\xd9\x88 \xd8\xa7\xd8\xb3\xd8"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3298 "\xaa\x2e \xd9\x85\xd9\x86 \xd8\xa7\xdb\x8c\xd8\xb1"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3299 "\xd9\x84\xd9\x86\xd8\xaf\xdb\x8c \xd8\xa7\xd9\x85"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3300 "\x2c \xd9\x88 \xd9\x85\xd9\x86 \xd8\xaf\xd8\xb1 "
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3301 "\xd8\xa8\xdb\x8c\xd9\x85\xd8\xa7\xd8\xb1\xd8\xb3"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3302 "\xd8\xaa\xd8\xa7\xd9\x86 \xda\xa9\xd8\xa7\xd8\xb1"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3303 "\xd9\x85\xdb\x8c\xe2\x80\x8c\xda\xa9\xd9\x86\xd9"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3304 "\x85\x2e")
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3305 (if (featurep 'mule) 'utf-8 'raw-text-unix)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3306 (long-string (concat long-string long-string long-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3307 long-string long-string long-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3308 long-string long-string long-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3309 long-string long-string long-string)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3310 `(with-temp-buffer
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3311 (let* ((long-string ,long-string)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3312 (stashed-data
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3313 (get-buffer-create
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3314 (generate-new-buffer-name " stash")))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3315 (function-output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3316 (apply-partially
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3317 #'(lambda (buffer character)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3318 (insert-char character 1 nil buffer))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3319 stashed-data))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3320 (marker-buffer
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3321 (get-buffer-create
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3322 (generate-new-buffer-name " for-marker")))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3323 (marker-base-position 40)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3324 (marker
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3325 (progn
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3326 (insert-char ?\xff 90 nil marker-buffer)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3327 (set-marker (make-marker) 40 marker-buffer))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3328 (unwind-protect
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3329 (labels
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3330 ((clear-buffer (buffer)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3331 (delete-region (point-min buffer) (point-max buffer)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3332 buffer))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3333 (clear-stashed-data (ignore)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3334 (delete-region (point-min stashed-data)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3335 (point-max stashed-data)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3336 stashed-data))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3337 (clear-marker-data (marker)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3338 (delete-region marker-base-position marker
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3339 (marker-buffer marker)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3340 (buffer-output (buffer length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3341 (and (> (point buffer) length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3342 (buffer-substring (- (point buffer) length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3343 (point buffer) buffer)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3344 (stashed-data-output (ignore length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3345 (and (> (point stashed-data) length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3346 (buffer-substring (- (point stashed-data)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3347 length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3348 (point stashed-data)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3349 stashed-data)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3350 (marker-data (marker length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3351 (and (> marker length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3352 (buffer-substring (- marker length) marker
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3353 (marker-buffer marker))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3354 (buffer-output-sans-newline (buffer length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3355 (and (> (point buffer) (+ length 1))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3356 (buffer-substring (- (point buffer) length 1)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3357 (1- (point buffer)))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3358 (stashed-data-output-sans-newline (ignore length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3359 (and (> (point stashed-data) (+ length 1))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3360 (buffer-substring (- (point stashed-data)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3361 length 1)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3362 (1- (point stashed-data))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3363 stashed-data)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3364 (marker-data-sans-newline (marker length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3365 (and (> marker (+ length 1))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3366 (buffer-substring (- marker length 1)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3367 (1- marker)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3368 (marker-buffer marker)))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3369 (Check-Error wrong-number-of-arguments (,function))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3370 (,(if (subrp (symbol-function function))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3371 'progn
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3372 'Implementation-Incomplete-Expect-Failure)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3373 (Check-Error wrong-number-of-arguments
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3374 (,function ,short-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3375 (current-buffer) :start))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3376 (Check-Error wrong-number-of-arguments
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3377 (,function ,short-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3378 (current-buffer) :start 0
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3379 :end nil :start)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3380 (Check-Error invalid-keyword-argument
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3381 (,function ,short-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3382 (current-buffer)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3383 :test #'eq))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3384 (Check-Error wrong-type-argument (,function pi))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3385 ,@(if sequences-too
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3386 `((Check-Error
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3387 args-out-of-range
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3388 (,function (vector most-positive-fixnum)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3389 (Check-Error
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3390 args-out-of-range
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3391 (,function (list most-positive-fixnum)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3392 ,@(if (featurep 'mule)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3393 `((Check-Error
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3394 args-out-of-range
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3395 (,function
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3396 (vector
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3397 (char-int
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3398 (decode-char 'ucs #x20ac))))))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3399 `((Check-Error wrong-type-argument
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3400 (,function
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3401 ',(append short-string nil)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3402 (Check-Error wrong-type-argument
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3403 (,function
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3404 ,(vconcat long-string)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3405 (Check-Error wrong-type-argument
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3406 (,function #*010010001010101))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3407 (Check-Error wrong-type-argument
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3408 (,function ,short-string (current-buffer)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3409 :start 0.0))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3410 (Check-Error wrong-type-argument
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3411 (,function ,short-string (current-buffer)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3412 :end 4.0))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3413 (Check-Error invalid-function
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3414 (,function ,short-string pi))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3415 (Check-Error args-out-of-range
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3416 (,function ,short-string (current-buffer)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3417 :end ,(1+ (length short-string))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3418 (Check-Error args-out-of-range
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3419 (,function ,short-string nil
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3420 :start
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3421 ,(1+ (length short-string))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3422 ;; Not checked here; output to a stdio stream, output
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3423 ;; to an lstream, output to a frame.
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3424 (Assert-write-results
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3425 ,function "buffer point" :short-string ,short-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3426 :long-string ,long-string :sequences-too ,sequences-too
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3427 :output-stream (current-buffer)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3428 :clear-output clear-buffer
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3429 :get-last-output
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3430 ,(if worry-about-newline 'buffer-output-sans-newline
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3431 'buffer-output))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3432 (Assert-write-results
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3433 ,function "function output" :short-string ,short-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3434 :long-string ,long-string :sequences-too ,sequences-too
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3435 :output-stream function-output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3436 :clear-output clear-stashed-data
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3437 :get-last-output
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3438 ,(if worry-about-newline
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3439 'stashed-data-output-sans-newline
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3440 'stashed-data-output))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3441 (Assert-write-results
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3442 ,function "marker output" :short-string ,short-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3443 :long-string ,long-string :sequences-too ,sequences-too
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3444 :output-stream marker :clear-output clear-marker-data
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3445 :get-last-output ,(if worry-about-newline
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3446 'marker-data-sans-newline
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3447 'marker-data)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3448 (kill-buffer stashed-data)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3449 (kill-buffer marker-buffer)))))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3450 (test-write-string write-sequence :sequences-too t)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3451 (test-write-string write-string :sequences-too nil)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3452 (test-write-string write-line :worry-about-newline t :sequences-too nil))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3453
4732 2491a837112c Fix typo in test of equalp and add more tests. Stephen J. Turnbull <stephen@xemacs.org> parents: 4728 diff changeset	3454 ;;; end of lisp-tests.el

Mercurial > hg > xemacs-beta

annotate tests/automated/lisp-tests.el @ 5797:a1808d52a34a