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

annotate tests/automated/lisp-tests.el @ 5420:b9167d522a9a

Rebase with 21.5 trunk.

author	Mats Lidell <matsl@xemacs.org>
date	Thu, 28 Oct 2010 23:53:24 +0200
parents	308d34e9f07d 2474dce7304e
children	46491edfd94a

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
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	32 (condition-case nil
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	33 (require 'test-harness)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	34 (file-error
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	35 (push "." load-path)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	36 (when (and (boundp 'load-file-name) (stringp load-file-name))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	37 (push (file-name-directory load-file-name) load-path))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	38 (require 'test-harness))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	39
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	40 (Check-Error wrong-number-of-arguments (setq setq-test-foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	41 (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	42 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	43 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo 1 setq-test-bar))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	44 (Assert (eq (setq) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	45 (Assert (eq (setq-default) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	46 (Assert (eq (setq setq-test-foo 42) 42))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	47 (Assert (eq (setq-default setq-test-foo 42) 42))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	48 (Assert (eq (setq setq-test-foo 42 setq-test-bar 99) 99))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	49 (Assert (eq (setq-default setq-test-foo 42 setq-test-bar 99) 99))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	50
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	51 (macrolet ((test-setq (expected-result &rest body)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	52 `(progn
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	53 (defun test-setq-fun () ,@body)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	54 (Assert (eq ,expected-result (test-setq-fun)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	55 (byte-compile 'test-setq-fun)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	56 (Assert (eq ,expected-result (test-setq-fun))))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	57 (test-setq nil (setq))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	58 (test-setq nil (setq-default))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	59 (test-setq 42 (setq test-setq-var 42))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	60 (test-setq 42 (setq-default test-setq-var 42))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	61 (test-setq 42 (setq test-setq-bar 99 test-setq-var 42))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	62 (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	63 )
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	64
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	65 (let ((my-vector [1 2 3 4])
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	66 (my-bit-vector (bit-vector 1 0 1 0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	67 (my-string "1234")
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	68 (my-list '(1 2 3 4)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	69
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	70 ;;(Assert (fooooo)) ;; Generate Other failure
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	71 ;;(Assert (eq 1 2)) ;; Generate Assertion failure
428 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 (dolist (sequence (list my-vector my-bit-vector my-string my-list))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	74 (Assert (sequencep sequence))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	75 (Assert (eq 4 (length sequence))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	76
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	77 (dolist (array (list my-vector my-bit-vector my-string))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	78 (Assert (arrayp array)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	79
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	80 (Assert (eq (elt my-vector 0) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	81 (Assert (eq (elt my-bit-vector 0) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	82 (Assert (eq (elt my-string 0) ?1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	83 (Assert (eq (elt my-list 0) 1))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	84
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	85 (fillarray my-vector 5)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	86 (fillarray my-bit-vector 1)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	87 (fillarray my-string ?5)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	88
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	89 (dolist (array (list my-vector my-bit-vector))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	90 (Assert (eq 4 (length array))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	91
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	92 (Assert (eq (elt my-vector 0) 5))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	93 (Assert (eq (elt my-bit-vector 0) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	94 (Assert (eq (elt my-string 0) ?5))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	95
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	96 (Assert (eq (elt my-vector 3) 5))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	97 (Assert (eq (elt my-bit-vector 3) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	98 (Assert (eq (elt my-string 3) ?5))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	99
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	100 (fillarray my-bit-vector 0)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	101 (Assert (eq 4 (length my-bit-vector)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	102 (Assert (eq (elt my-bit-vector 2) 0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	103 )
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	104
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	105 (defun make-circular-list (length)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	106 "Create evil emacs-crashing circular list of length LENGTH"
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	107 (let ((circular-list
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	108 (make-list
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	109 length
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	110 'you-are-trapped-in-a-twisty-maze-of-cons-cells-all-alike)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	111 (setcdr (last circular-list) circular-list)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	112 circular-list))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	113
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	114 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	115 ;; Test `nconc'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	116 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	117 (defun make-list-012 () (list 0 1 2))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	118
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	119 (Check-Error wrong-type-argument (nconc 'foo nil))
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 (dolist (length '(1 2 3 4 1000 2000))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	122 (Check-Error circular-list (nconc (make-circular-list length) 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	123 (Check-Error circular-list (nconc '(1 . 2) (make-circular-list length) 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	124 (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	125
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	126 (Assert (eq (nconc) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	127 (Assert (eq (nconc nil) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	128 (Assert (eq (nconc nil nil) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	129 (Assert (eq (nconc nil nil nil) nil))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	130
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	131 (let ((x (make-list-012))) (Assert (eq (nconc nil x) x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	132 (let ((x (make-list-012))) (Assert (eq (nconc x nil) x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	133 (let ((x (make-list-012))) (Assert (eq (nconc nil x nil) x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	134 (let ((x (make-list-012))) (Assert (eq (nconc x) x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	135 (let ((x (make-list-012))) (Assert (eq (nconc x (make-circular-list 3)) x)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	136
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	137 (Assert (equal (nconc '(1 . 2) '(3 . 4) '(5 . 6)) '(1 3 5 . 6)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	138
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	139 (let ((y (nconc (make-list-012) nil (list 3 4 5) nil)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	140 (Assert (eq (length y) 6))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	141 (Assert (eq (nth 3 y) 3)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	142
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	143 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	144 ;; Test `last'
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 (Check-Error wrong-type-argument (last 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	147 (Check-Error wrong-number-of-arguments (last))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	148 (Check-Error wrong-number-of-arguments (last '(1 2) 1 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	149 (Check-Error circular-list (last (make-circular-list 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	150 (Check-Error circular-list (last (make-circular-list 2000)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	151 (let ((x (list 0 1 2 3)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	152 (Assert (eq (last nil) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	153 (Assert (eq (last x 0) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	154 (Assert (eq (last x ) (cdddr x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	155 (Assert (eq (last x 1) (cdddr x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	156 (Assert (eq (last x 2) (cddr x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	157 (Assert (eq (last x 3) (cdr x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	158 (Assert (eq (last x 4) x))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	159 (Assert (eq (last x 9) x))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	160 (Assert (eq (last '(1 . 2) 0) 2))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	161 )
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	162
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	163 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	164 ;; Test `butlast' and `nbutlast'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	165 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	166 (Check-Error wrong-type-argument (butlast 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	167 (Check-Error wrong-type-argument (nbutlast 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	168 (Check-Error wrong-number-of-arguments (butlast))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	169 (Check-Error wrong-number-of-arguments (nbutlast))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	170 (Check-Error wrong-number-of-arguments (butlast '(1 2) 1 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	171 (Check-Error wrong-number-of-arguments (nbutlast '(1 2) 1 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	172 (Check-Error circular-list (butlast (make-circular-list 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	173 (Check-Error circular-list (nbutlast (make-circular-list 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	174 (Check-Error circular-list (butlast (make-circular-list 2000)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	175 (Check-Error circular-list (nbutlast (make-circular-list 2000)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	176
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	177 (let* ((x (list 0 1 2 3))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	178 (y (butlast x))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	179 (z (nbutlast x)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	180 (Assert (eq z x))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	181 (Assert (not (eq y x)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	182 (Assert (equal y '(0 1 2)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	183 (Assert (equal z y)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	184
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	185 (let* ((x (list 0 1 2 3 4))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	186 (y (butlast x 2))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	187 (z (nbutlast x 2)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	188 (Assert (eq z x))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	189 (Assert (not (eq y x)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	190 (Assert (equal y '(0 1 2)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	191 (Assert (equal z y)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	192
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	193 (let* ((x (list 0 1 2 3))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	194 (y (butlast x 0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	195 (z (nbutlast x 0)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	196 (Assert (eq z x))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	197 (Assert (not (eq y x)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	198 (Assert (equal y '(0 1 2 3)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	199 (Assert (equal z y)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	200
5285 99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	201 (let* ((x (list* 0 1 2 3 4 5 6.0 ?7 ?8 (vector 'a 'b 'c)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	202 (y (butlast x 0))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	203 (z (nbutlast x 0)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	204 (Assert (eq z x))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	205 (Assert (not (eq y x)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	206 (Assert (equal y '(0 1 2 3 4 5 6.0 ?7 ?8)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	207 (Assert (equal z y)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	208
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	209 (Assert (eq (butlast '(x)) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	210 (Assert (eq (nbutlast '(x)) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	211 (Assert (eq (butlast '()) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	212 (Assert (eq (nbutlast '()) nil))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	213
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	214 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	215 ;; Test `copy-list'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	216 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	217 (Check-Error wrong-type-argument (copy-list 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	218 (Check-Error wrong-number-of-arguments (copy-list))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	219 (Check-Error wrong-number-of-arguments (copy-list '(1 2) 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	220 (Check-Error circular-list (copy-list (make-circular-list 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	221 (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	222 (Assert (eq '() (copy-list '())))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	223 (dolist (x '((1) (1 2) (1 2 3) (1 2 . 3)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	224 (let ((y (copy-list x)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	225 (Assert (and (equal x y) (not (eq x y))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	226
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	227 ;;-----------------------------------------------------
5285 99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	228 ;; Test `ldiff'
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	229 ;;-----------------------------------------------------
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	230 (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	231 (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	232 (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	233 (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	234 (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	235 (Assert (eq '() (ldiff '() pi)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	236 (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	237 (let ((y (ldiff x nil)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	238 (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	239
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	240 (let* ((vector (vector 'foo))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	241 (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	242 (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	243 without-vector without-pi)
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	244 (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	245 "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	246 (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	247 "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	248 (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	249 "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	250
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	251 ;;-----------------------------------------------------
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	252 ;; Test `tailp'
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	253 ;;-----------------------------------------------------
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	254 (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	255 (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	256 (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	257 (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	258 (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	259 (Assert (null (tailp pi '()))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	260 "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	261 (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	262 "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	263 (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	264 "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	265 (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	266 (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	267 "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	268
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	269 ;;-----------------------------------------------------
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	270 ;; Test `endp'
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	271 ;;-----------------------------------------------------
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	272 (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	273 (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	274 (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	275 (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	276 (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	277 "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	278
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	279 ;;-----------------------------------------------------
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	280 ;; Arithmetic operations
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	281 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	282
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	283 ;; Test `+'
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	284 (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	285 (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	286 (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	287 (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	288 (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	289 (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	290 (Assert (= (+ 1 1 1.0) 3.0))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	291 (if (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	292 (progn
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	293 (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	294 (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	295 (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	296 (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	297 (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	298 (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	299 3))))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	300 (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	301 (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	302
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	303 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	304 (let ((threefourths (read "3/4"))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	305 (threehalfs (read "3/2"))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	306 (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	307 (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	308 (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	309 (Assert (= negone -1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	310 (Assert (= threehalfs (+ threefourths threefourths)))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	311 (Assert (zerop (+ bigpos bigneg)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	312
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	313 ;; Test `-'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	314 (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	315 (Assert (eq (- 0) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	316 (Assert (eq (- 1) -1))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	317 (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	318 (Assert (= (+ 1 one) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	319 (Assert (= (+ one) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	320 (Assert (= (+ one) one))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	321 (Assert (= (- one) -1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	322 (Assert (= (- one one) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	323 (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	324 (Assert (= (- 0 one) -1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	325 (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	326 (Assert (= (+ one 1) 2))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	327 (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	328 (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	329 (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	330 (Assert (= (- zero) zero) zero)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	331 (Assert (= (- zero) 0) zero)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	332 (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	333 (Assert (= (- zero one one) -2) zero)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	334
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	335 (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	336 (Assert (= (- 1 1.5) (- .5)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	337
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	338 (if (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	339 (progn
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	340 (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	341 (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	342 (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	343 (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	344 (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	345 (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	346 (* 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	347 1)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	348 (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	349 (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	350
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	351 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	352 (let ((threefourths (read "3/4"))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	353 (threehalfs (read "3/2"))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	354 (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	355 (bigneg (div most-positive-fixnum most-negative-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	356 (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	357 (Assert (= (- negone) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	358 (Assert (= threefourths (- threehalfs threefourths)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	359 (Assert (= (- bigpos bigneg) 2))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	360
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	361 ;; Test `/'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	362
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	363 ;; Test division by zero errors
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	364 (dolist (zero '(0 0.0 ?\0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	365 (Check-Error arith-error (/ zero))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	366 (dolist (n1 `(42 42.0 ?\042 ,(Int-to-Marker 42)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	367 (Check-Error arith-error (/ n1 zero))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	368 (dolist (n2 `(3 3.0 ?\03 ,(Int-to-Marker 3)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	369 (Check-Error arith-error (/ n1 n2 zero)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	370
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	371 ;; Other tests for `/'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	372 (Check-Error wrong-number-of-arguments (/))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	373 (let (x)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	374 (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	375 (Assert (= (/ (setq x 2.0)) 0.5)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	376
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	377 (dolist (six '(6 6.0 ?\06))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	378 (dolist (two '(2 2.0 ?\02))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	379 (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	380 (Assert (= (/ six two) three) (list six two three)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	381
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	382 (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	383 (Assert (= (/ three 2.0) 1.5) three))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	384 (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	385 (Assert (= (/ 3.0 two) 1.5) two))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	386
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	387 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	388 (let* ((million 1000000)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	389 (billion (* million 1000)) ;; American, not British, billion
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	390 (trillion (* billion 1000)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	391 (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	392 (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	393 (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	394 (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	395 (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	396 (Assert (= (/ (- trillion) 10) (* -100 billion) -100000000000.0))))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	397
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	398 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	399 (let ((half (div 1 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	400 (fivefourths (div 5 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	401 (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	402 (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	403 (Assert (= (/ fivehalfs fivefourths) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	404 (Assert (= (/ fivefourths fivehalfs) half))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	405 (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	406 (Assert (= (/ fivehalfs (- fivefourths)) -2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	407 (Assert (= (/ (- fivefourths) fivehalfs) (- half)))))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	408
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	409 ;; Test `*'
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	410 (Assert (= 1 (*)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	411
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	412 (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	413 (Assert (= 1 (* one)) one))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	414
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	415 (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	416 (Assert (= 2 (* two)) two))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	417
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	418 (dolist (six '(6 6.0 ?\06))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	419 (dolist (two '(2 2.0 ?\02))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	420 (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	421 (Assert (= (* three two) six) (list three two six)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	422
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	423 (dolist (three '(3 3.0 ?\03))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	424 (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	425 (Assert (= (* 1.5 two) three) (list two three))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	426 (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	427 (Assert (= 30 (* five two three)) (list five two three)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	428
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	429 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	430 (let ((64K 65536))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	431 (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	432 (Assert (= (* (- 64K) 64K) (read "-4294967296")))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	433 (Assert (/= (* -1 most-negative-fixnum) most-negative-fixnum))))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	434
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	435 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	436 (let ((half (div 1 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	437 (fivefourths (div 5 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	438 (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	439 (Assert (= (* fivefourths twofifths) half))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	440 (Assert (= (* half twofifths) (read "3/15")))))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	441
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	442 ;; Test `+'
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	443 (Assert (= 0 (+)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	444
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	445 (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	446 (Assert (= 1 (+ one)) one))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	447
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	448 (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	449 (Assert (= 2 (+ two)) two))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	450
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	451 (dolist (five '(5 5.0 ?\05))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	452 (dolist (two '(2 2.0 ?\02))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	453 (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	454 (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	455 (Assert (= 10 (+ five two three)) (list five two three)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	456
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	457 ;; Test `max', `min'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	458 (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	459 (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	460 (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	461 (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	462 (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	463 (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	464 (Assert (= one (min one one one)) one)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	465 (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	466 (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	467 (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	468 (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	469 (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	470 (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	471 (Assert (= two (max two two one)) (list one two))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	472
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	473 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	474 (let ((big (1+ most-positive-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	475 (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	476 (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	477 (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	478
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	479 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	480 (let* ((big (1+ most-positive-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	481 (small (1- most-negative-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	482 (bigr (div (* 5 (1+ most-positive-fixnum)) 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	483 (smallr (- bigr)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	484 (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	485 (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	486
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	487 ;; The byte compiler has special handling for these constructs:
1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	488 (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	489 (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	490 (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	491 (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	492 (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	493 (Assert (= (+ three 1) 4))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	494 (Assert (= (+ three -1) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	495 (Assert (= (+ -1 three) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	496 (Assert (= (+ -1 three) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	497 (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	498 (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	499 (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	500 (Assert (= (- -1 three five) -9))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	501 (Assert (= (- three 1) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	502 (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	503 (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	504 (Assert (= (- three -1) 4))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	505 (Assert (= (- three 0) 3))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	506 (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	507 (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	508 (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	509 (Assert (= (* three 2) 6))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	510 (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	511 (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	512 (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	513 (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	514 (Assert (= (/ three 1) 3))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	515 (Assert (= (/ three -1) -3))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	516 (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	517 (Assert (= (/ 64 five 2) 6)))
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	518
1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	519
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	520 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	521 ;; Logical bit-twiddling operations
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	522 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	523 (Assert (= (logxor) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	524 (Assert (= (logior) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	525 (Assert (= (logand) -1))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	526
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	527 (Check-Error wrong-type-argument (logxor 3.0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	528 (Check-Error wrong-type-argument (logior 3.0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	529 (Check-Error wrong-type-argument (logand 3.0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	530
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	531 (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	532 (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	533 (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	534 (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	535 (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	536 (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	537 (Assert (eq 3 (logior three three))) three)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	538
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	539 (dolist (one `(1 ?\01 ,(Int-to-Marker 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	540 (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	541 (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	542 (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	543 (Assert (eq 3 (logxor one two)) (list one two)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	544 (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	545 (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	546 (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	547 (Assert (eq 2 (logxor one three)) (list one three))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	548
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	549 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	550 ;; Test `%', mod
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	551 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	552 (Check-Error wrong-number-of-arguments (%))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	553 (Check-Error wrong-number-of-arguments (% 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	554 (Check-Error wrong-number-of-arguments (% 1 2 3))
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 (Check-Error wrong-number-of-arguments (mod))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	557 (Check-Error wrong-number-of-arguments (mod 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	558 (Check-Error wrong-number-of-arguments (mod 1 2 3))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	559
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	560 (Check-Error wrong-type-argument (% 10.0 2))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	561 (Check-Error wrong-type-argument (% 10 2.0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	562
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	563 (flet ((test1 (x) (Assert (eql x (+ (% x 17) (* (/ x 17) 17))) x))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	564 (test2 (x) (Assert (eql (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17))) x))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	565 (test3 (x) (Assert (eql x (+ (% (- x) 17) (* (/ (- x) 17) 17))) x))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	566 (test4 (x) (Assert (eql (% x -17) (- (% (- x) 17))) x))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	567 (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	568 (test1 most-negative-fixnum)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	569 (if (featurep 'bignum)
2075 c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james] james parents: 2056 diff changeset	570 (progn
c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james] james parents: 2056 diff changeset	571 (test2 most-negative-fixnum)
c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james] james parents: 2056 diff changeset	572 (test4 most-negative-fixnum))
c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james] james parents: 2056 diff changeset	573 (test3 most-negative-fixnum)
c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james] james parents: 2056 diff changeset	574 (test5 most-negative-fixnum))
2056 ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	575 (test1 most-positive-fixnum)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	576 (test2 most-positive-fixnum)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	577 (test4 most-positive-fixnum)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	578 (dotimes (j 30)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	579 (let ((x (random)))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	580 (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	581 (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	582 (test1 x)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	583 (test2 x)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	584 (test4 x))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	585
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	586 (macrolet
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	587 ((division-test (seven)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	588 `(progn
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	589 (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	590 (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	591 (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	592 (Assert (eq (% (- ,seven) -2) -1))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	593
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	594 (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	595 (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	596 (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	597 (Assert (eq (% (- ,seven) -4) -3))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	598
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	599 (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	600 (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	601 (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	602 (Assert (eq (% -35 (- ,seven)) 0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	603
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	604 (Assert (eq (mod ,seven 2) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	605 (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	606 (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	607 (Assert (eq (mod (- ,seven) -2) -1))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	608
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	609 (Assert (eq (mod ,seven 4) 3))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	610 (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	611 (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	612 (Assert (eq (mod (- ,seven) -4) -3))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	613
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	614 (Assert (eq (mod 35 ,seven) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	615 (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	616 (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	617 (Assert (eq (mod -35 (- ,seven)) 0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	618
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	619 (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	620 (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	621 (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	622 (Assert (= (mod (- ,seven) -2.0) -1.0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	623
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	624 (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	625 (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	626 (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	627 (Assert (= (mod (- ,seven) -4.0) -3.0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	628
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	629 (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	630 (Assert (eq (% 0 (- ,seven)) 0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	631
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	632 (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	633 (Assert (eq (mod 0 (- ,seven)) 0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	634
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	635 (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	636 (Assert (= (mod 0.0 (- ,seven)) 0.0)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	637
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	638 (division-test 7)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	639 (division-test ?\07)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	640 (division-test (Int-to-Marker 7)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	641
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	642 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	643 (let ((big (+ (* 7 most-positive-fixnum 6)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	644 (negbig (- (* 7 most-negative-fixnum 6))))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	645 (= (% big (1+ most-positive-fixnum)) most-positive-fixnum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	646 (= (% negbig (1- most-negative-fixnum)) most-negative-fixnum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	647 (= (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	648 (= (mod negbig (1- most-negative-fixnum)) most-negative-fixnum)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	649
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	650 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	651 ;; Arithmetic comparison operations
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	652 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	653 (Check-Error wrong-number-of-arguments (=))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	654 (Check-Error wrong-number-of-arguments (<))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	655 (Check-Error wrong-number-of-arguments (>))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	656 (Check-Error wrong-number-of-arguments (<=))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	657 (Check-Error wrong-number-of-arguments (>=))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	658 (Check-Error wrong-number-of-arguments (/=))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	659
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	660 ;; One argument always yields t
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	661 (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	662 (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	663 (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	664 (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	665 (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	666 (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	667 (Assert (eq t (/= x)) x)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	668 )
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 ;; Type checking
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	671 (Check-Error wrong-type-argument (= 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	672 (Check-Error wrong-type-argument (<= 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	673 (Check-Error wrong-type-argument (>= 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	674 (Check-Error wrong-type-argument (< 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	675 (Check-Error wrong-type-argument (> 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	676 (Check-Error wrong-type-argument (/= 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	677
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	678 ;; Meat
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	679 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	680 (dolist (two '(2 2.0 ?\02))
2056 ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	681 (Assert (< one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	682 (Assert (<= one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	683 (Assert (<= two two) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	684 (Assert (> two one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	685 (Assert (>= two one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	686 (Assert (>= two two) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	687 (Assert (/= one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	688 (Assert (not (/= two two)) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	689 (Assert (not (< one one)) one)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	690 (Assert (not (> one one)) one)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	691 (Assert (<= one one two two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	692 (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	693 (Assert (>= two two one one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	694 (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	695 (Assert (= one one one) one)
2056 ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	696 (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	697 (Assert (not (/= one two one)) (list one two))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	698 ))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	699
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	700 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	701 (dolist (two '(2 2.0 ?\02))
2056 ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	702 (Assert (< one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	703 (Assert (<= one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	704 (Assert (<= two two) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	705 (Assert (> two one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	706 (Assert (>= two one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	707 (Assert (>= two two) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	708 (Assert (/= one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	709 (Assert (not (/= two two)) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	710 (Assert (not (< one one)) one)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	711 (Assert (not (> one one)) one)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	712 (Assert (<= one one two two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	713 (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	714 (Assert (>= two two one one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	715 (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	716 (Assert (= one one one) one)
2056 ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	717 (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	718 (Assert (not (/= one two one)) (list one two))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	719 ))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	720
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	721 ;; ad-hoc
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	722 (Assert (< 1 2))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	723 (Assert (< 1 2 3 4 5 6))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	724 (Assert (not (< 1 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	725 (Assert (not (< 2 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	726
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	727
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	728 (Assert (not (< 1 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	729 (Assert (< 1 2 3 4 5 6))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	730 (Assert (<= 1 2 3 4 5 6))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	731 (Assert (<= 1 2 3 4 5 6 6))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	732 (Assert (not (< 1 2 3 4 5 6 6)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	733 (Assert (<= 1 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	734
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	735 (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	736 (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	737 (Assert (= (point) (point-marker)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	738
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	739 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	740 (let ((big1 (1+ most-positive-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	741 (big2 (* 10 most-positive-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	742 (small1 (1- most-negative-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	743 (small2 (* 10 most-negative-fixnum)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	744 (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	745 big2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	746 (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	747 big2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	748 (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	749 small2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	750 (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	751 small2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	752 (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	753 big2))))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	754
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	755 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	756 (let ((big1 (div (* 10 most-positive-fixnum) 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	757 (big2 (div (* 5 most-positive-fixnum) 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	758 (big3 (div (* 7 most-positive-fixnum) 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	759 (small1 (div (* 10 most-negative-fixnum) 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	760 (small2 (div (* 5 most-negative-fixnum) 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	761 (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	762 (Assert (= big1 big2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	763 (Assert (= small1 small2))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	764 (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	765 big3))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	766 (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	767 big1 big2 big3))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	768 (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	769 small3))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	770 (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	771 small1 small2 small3))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	772 (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	773 small3))))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	774
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	775 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	776 ;; testing list-walker functions
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	777 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	778 (macrolet
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	779 ((test-fun
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	780 (fun)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	781 `(progn
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	782 (Check-Error wrong-number-of-arguments (,fun))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	783 (Check-Error wrong-number-of-arguments (,fun nil))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	784 (Check-Error malformed-list (,fun nil 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	785 ,@(loop for n in '(1 2 2000)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	786 collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	787 (test-funs (&rest funs) `(progn ,@(loop for fun in funs collect `(test-fun ,fun)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	788
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	789 (test-funs member old-member
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	790 memq old-memq
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	791 assoc old-assoc
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	792 rassoc old-rassoc
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	793 rassq old-rassq
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	794 delete old-delete
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	795 delq old-delq
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	796 remassoc remassq remrassoc remrassq))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	797
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	798 (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	799 (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	800 (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	801 (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	802 (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	803 (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	804 (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	805 (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	806 (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	807 (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	808 (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	809 (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	810 (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	811 (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	812 (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	813 (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	814 (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	815 (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	816 (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	817 (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	818 (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	819 (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	820 (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	821 (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	822 (Assert (eq (rassq 6 x) nil)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	823
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	824 (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	825 (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	826 (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	827 (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	828 (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	829 (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	830 (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	831 (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	832 (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	833 (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	834 (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	835 (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	836 (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	837 (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	838 (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	839 (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	840 (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	841 (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	842 (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	843 (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	844 (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	845 (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	846 (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	847 (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	848 (Assert (eq (rassq "6" x) nil)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	849
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	850 (flet ((a () (list '(1 . 2) 3 '(4 . 5))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	851 (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	852 (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	853 (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	854 (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	855
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	856 (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	857 (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	858 (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	859 (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	860
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	861 (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	862 (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	863 (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	864 (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	865
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	866 (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	867 (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	868 (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	869 (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	870
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	871 (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	872 (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	873 (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	874 (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	875
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	876 (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	877 (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	878 (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	879 (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	880
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	881 (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	882 (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	883 (Assert (let* ((x (a)) (y (old-delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	884 (Assert (let* ((x (a)) (y (old-delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	885
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	886 (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	887 (Assert (let* ((x (a)) (y (delq '(1 . 2) x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	888 (Assert (let* ((x (a)) (y (old-delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	889 (Assert (let* ((x (a)) (y (old-delq '(1 . 2) x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	890 )
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	891
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	892
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	893
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	894 (flet ((a () (list '("1" . "2") "3" '("4" . "5"))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	895 (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	896 (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	897 (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	898 (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	899
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	900 (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	901 (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	902 (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	903 (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	904
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	905 (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	906 (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	907 (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	908 (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	909
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	910 (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	911 (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	912 (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	913 (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	914
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	915 (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	916 (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	917 (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	918 (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	919
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	920 (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	921 (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	922 (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	923 (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	924
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	925 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	926 ;; function-max-args, function-min-args
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	927 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	928 (defmacro check-function-argcounts (fun min max)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	929 `(progn
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	930 (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	931 (Assert (eq (function-max-args ,fun) ,max))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	932
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	933 (check-function-argcounts 'prog1 1 nil) ; special form
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	934 (check-function-argcounts 'command-execute 1 3) ; normal subr
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	935 (check-function-argcounts 'funcall 1 nil) ; `MANY' subr
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	936 (check-function-argcounts 'garbage-collect 0 0) ; no args subr
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	937
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	938 ;; Test interpreted and compiled functions
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	939 (loop for (arglist min max) in
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	940 '(((arg1 arg2 &rest args) 2 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	941 ((arg1 arg2 &optional arg3 arg4) 2 4)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	942 ((arg1 arg2 &optional arg3 arg4 &rest args) 2 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	943 (() 0 0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	944 do
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	945 (eval
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	946 `(progn
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	947 (defun test-fun ,arglist nil)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	948 (check-function-argcounts '(lambda ,arglist nil) ,min ,max)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	949 (check-function-argcounts (byte-compile '(lambda ,arglist nil)) ,min ,max))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	950
4575 eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	951 ;; Test subr-arity.
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	952 (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	953 '((let (1 . unevalled))
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	954 (prog1 (1 . unevalled))
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	955 (list (0 . many))
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	956 (type-of (1 . 1))
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	957 (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	958 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	959
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	960 (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	961 (lambda () (message "Hi there!"))))
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	962
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	963 (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	964
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	965 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	966 ;; Detection of cyclic variable indirection loops
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	967 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	968 (fset 'test-sym1 'test-sym1)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	969 (Check-Error cyclic-function-indirection (test-sym1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	970
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	971 (fset 'test-sym1 'test-sym2)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	972 (fset 'test-sym2 'test-sym1)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	973 (Check-Error cyclic-function-indirection (test-sym1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	974 (fmakunbound 'test-sym1) ; else macroexpand-internal infloops!
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	975 (fmakunbound 'test-sym2)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	976
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	977 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	978 ;; Test `type-of'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	979 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	980 (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	981 (Assert (eq (type-of obarray) 'vector))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	982 (Assert (eq (type-of 42) 'integer))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	983 (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	984 (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	985 (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	986 (Assert (eq (type-of (selected-device)) 'device))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	987
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	988 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	989 ;; Test mapping functions
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	990 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	991 (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	992 (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	993 (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	994 (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	995 (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	996 (Assert (equal (mapcar #'identity #*010) '(0 1 0)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	997
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	998 (let ((z 0) (list (make-list 1000 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	999 (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	1000 (Assert (eq 1000 z)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1001
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1002 (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	1003 (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	1004 (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	1005 (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	1006 (Assert (equal (mapvector #'identity #*010) [0 1 0]))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1007
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1008 (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	1009 (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	1010 (Assert (equal (mapconcat #'identity ["1" "2" "3"] "\|") "1\|2\|3"))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1011
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1012 ;; The following 2 functions used to crash XEmacs via mapcar1().
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1013 ;; 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	1014 (Assert
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1015 (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	1016 (mapcar
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1017 (lambda (y)
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1018 "Devious evil mapping function"
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1019 (when (eq (car y) 2) ; go out onto a limb
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1020 (setcdr x nil) ; cut it off behind us
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1021 (garbage-collect)) ; are we riding a magic broomstick?
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1022 (car y)) ; sorry, hard landing
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1023 x)))
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1024
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1025 (Assert
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1026 (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	1027 (mapcar
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1028 (lambda (y)
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1029 "Devious evil mapping function"
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1030 (when (eq (car y) 1)
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1031 (setcdr (cdr x) 42)) ; drop a brick wall onto the freeway
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1032 (car y))
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1033 x)))
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1034
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1035 (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	1036 (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	1037 (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	1038 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	1039 "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	1040
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1041 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1042 ;; Test vector functions
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1043 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1044 (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	1045 (Assert (equal [] []))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1046 (Assert (not (equal [1 2 3] [])))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1047 (Assert (not (equal [1 2 3] [1 2 4])))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1048 (Assert (not (equal [0 2 3] [1 2 3])))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1049 (Assert (not (equal [1 2 3] [1 2 3 4])))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1050 (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	1051 (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	1052 (Assert (equal (make-vector 3 1) [1 1 1]))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1053
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1054 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1055 ;; Test bit-vector functions
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1056 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1057 (Assert (equal #010 #010))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1058 (Assert (equal #* #*))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1059 (Assert (not (equal #010 #011)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1060 (Assert (not (equal #010 #)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1061 (Assert (not (equal #110 #010)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1062 (Assert (not (equal #010 #0100)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1063 (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	1064 (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	1065 (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	1066 (Assert (equal (make-bit-vector 3 0) #*000))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1067
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 buffer-local variables used as (ugh!) function parameters
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1070 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1071 (make-local-variable 'test-emacs-buffer-local-variable)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1072 (byte-compile
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1073 (defun test-emacs-buffer-local-parameter (test-emacs-buffer-local-variable)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1074 (setq test-emacs-buffer-local-variable nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1075 (test-emacs-buffer-local-parameter nil)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1076
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1077 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1078 ;; Test split-string
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1079 ;;-----------------------------------------------------
1425 74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent] stephent parents: 826 diff changeset	1080 ;; Keep nulls, explicit SEPARATORS
74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent] stephent parents: 826 diff changeset	1081 ;; 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	1082 ;; 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	1083 (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	1084 (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	1085 (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	1086 (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	1087 (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	1088 (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	1089 (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	1090 (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	1091 (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	1092 (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	1093 (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	1094 (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	1095 (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	1096 ;; Omit nulls, explicit SEPARATORS
74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent] stephent parents: 826 diff changeset	1097 (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	1098 (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	1099 (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	1100 (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	1101 (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	1102 (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	1103 (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	1104 (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	1105 (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	1106 (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	1107 (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	1108 (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	1109 (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	1110 ;; "Double-default" case
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 bar") '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1112 (Assert (equal (split-string " foo bar ") '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1113 (Assert (equal (split-string " foo bar ") '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1114 (Assert (equal (split-string "foo bar") '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1115 (Assert (equal (split-string "foo bar ") '("foo" "bar")))
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 "foobar") '("foobar")))
1425 74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent] stephent parents: 826 diff changeset	1117 ;; 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	1118 (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	1119 (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	1120 (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	1121 (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	1122 (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	1123 (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	1124 ;; 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	1125 (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	1126 '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1127 (Assert (equal (split-string " foo bar " split-string-default-separators)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1128 '("" "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 " split-string-default-separators)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1130 '("" "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" split-string-default-separators)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1132 '("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 " split-string-default-separators)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1134 '("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 "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	1136 '("foobar")))
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1137
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1138 ;;-----------------------------------------------------
5035 b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1139 ;; 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	1140 ;;-----------------------------------------------------
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1141
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1142 (Assert
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1143 (equal
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1144 (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	1145 #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	1146 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	1147 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	1148 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	1149 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	1150 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	1151 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	1152 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	1153 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	1154 ?: ?\\)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1155 '("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	1156 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	1157 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	1158 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	1159 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	1160 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	1161 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	1162 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	1163 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	1164 (Assert
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1165 (equal
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1166 (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 #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	1168 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	1169 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	1170 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	1171 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	1172 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	1173 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	1174 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	1175 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	1176 ?: ?\x00)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1177 '("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	1178 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	1179 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	1180 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	1181 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	1182 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	1183 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	1184 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	1185 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	1186 (Assert
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1187 (equal
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1188 (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	1189 #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	1190 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	1191 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	1192 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	1193 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	1194 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	1195 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	1196 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	1197 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	1198 '("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	1199 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	1200 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	1201 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	1202 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	1203 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	1204 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	1205 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	1206 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	1207
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1208 ;;-----------------------------------------------------
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1209 ;; Test near-text buffer functions.
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1210 ;;-----------------------------------------------------
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1211 (with-temp-buffer
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1212 (erase-buffer)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1213 (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	1214 (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	1215 (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	1216 (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	1217 (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	1218 (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	1219 (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	1220 (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	1221 (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	1222 (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	1223 (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	1224 (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	1225 (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	1226 (Assert (eq (following-char (current-buffer)) 0))
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1227 (insert "foobar")
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1228 (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	1229 (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	1230 (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	1231 (Assert (eq (following-char) 0))
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1232 (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	1233 (Assert (eq (char-before) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1234 (Assert (eq (char-after) ?f))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1235 (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	1236 (Assert (eq (following-char) ?f))
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1237 )
440 8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1238
8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1239 ;;-----------------------------------------------------
8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1240 ;; Test plist manipulation functions.
8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1241 ;;-----------------------------------------------------
8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1242 (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	1243 (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	1244 (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	1245 (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	1246 (Assert (eq t (plist-get nil t t)))
440 8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1247 (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	1248 (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	1249 (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	1250 (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	1251 (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	1252 (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	1253 (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	1254 (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	1255 (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	1256 (Assert (eq 5 (get sym 3 5)))
440 8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1257 )
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1258
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1259 (loop for obj in
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1260 (list (make-symbol "test-symbol")
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1261 "test-string"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1262 (make-extent nil nil nil)
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1263 (make-face 'test-face))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1264 do
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1265 (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	1266 (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	1267 (Assert (eq 4 (get obj ?3)) obj)
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1268 (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	1269 (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	1270 (Assert (eq t (remprop obj ?3)) obj)
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1271 (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	1272 (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	1273 (Assert (eq nil (remprop obj ?3)) obj)
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1274 (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	1275 (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	1276 (Assert (eq 5 (get obj ?3 5)) obj)
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1277 )
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1278
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1279 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1280 error "Object type has no properties"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1281 (get 2 'property))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1282
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1283 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1284 error "Object type has no settable properties"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1285 (put (current-buffer) 'property 'value))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1286
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1287 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1288 error "Object type has no removable properties"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1289 (remprop ?3 'property))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1290
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1291 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1292 error "Object type has no properties"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1293 (object-plist (symbol-function 'car)))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1294
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1295 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1296 error "Can't remove property from object"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1297 (remprop (make-extent nil nil nil) 'detachable))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1298
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1299 ;;-----------------------------------------------------
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1300 ;; Test subseq
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1301 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1302 (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	1303 (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	1304 (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	1305 (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	1306 (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	1307 (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	1308 (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	1309 (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	1310 (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	1311
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1312 (Check-Error wrong-type-argument (subseq 3 2))
1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1313 (Check-Error args-out-of-range (subseq [1 2 3] -42))
1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1314 (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	1315
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1316 ;;-----------------------------------------------------
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1317 ;; Time-related tests
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1318 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1319 (Assert (= (length (current-time-string)) 24))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1320
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1321 ;;-----------------------------------------------------
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1322 ;; format test
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1323 ;;-----------------------------------------------------
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1324 (Assert (string= (format "%d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1325 (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	1326 (Assert (string= (format "%b" 2) "10"))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1327 (Assert (string= (format "%x" 31) "1f"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1328 (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	1329 (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	1330 (Assert (string= (format "%b" 3) "11"))
826 6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1331 ;; 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	1332 ;; 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	1333 ;; is very hard.
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1334 (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	1335 (string= (format "%e" 100) "1.000000e+002")))
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1336 (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	1337 (string= (format "%E" 100) "1.000000E+002")))
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1338 (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	1339 (string= (format "%E" 100) "1.000000E+002")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1340 (Assert (string= (format "%f" 100) "100.000000"))
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1341 (Assert (string= (format "%7.3f" 12.12345) " 12.123"))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1342 (Assert (string= (format "%07.3f" 12.12345) "012.123"))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1343 (Assert (string= (format "%-7.3f" 12.12345) "12.123 "))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1344 (Assert (string= (format "%-07.3f" 12.12345) "12.123 "))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1345 (Assert (string= (format "%g" 100.0) "100"))
826 6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1346 (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	1347 (string= (format "%g" 0.000001) "1e-006")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1348 (Assert (string= (format "%g" 0.0001) "0.0001"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1349 (Assert (string= (format "%G" 100.0) "100"))
826 6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1350 (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	1351 (string= (format "%G" 0.000001) "1E-006")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1352 (Assert (string= (format "%G" 0.0001) "0.0001"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1353
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1354 (Assert (string= (format "%2$d%1$d" 10 20) "2010"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1355 (Assert (string= (format "%-d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1356 (Assert (string= (format "%-4d" 10) "10 "))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1357 (Assert (string= (format "%+d" 10) "+10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1358 (Assert (string= (format "%+d" -10) "-10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1359 (Assert (string= (format "%+4d" 10) " +10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1360 (Assert (string= (format "%+4d" -10) " -10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1361 (Assert (string= (format "% d" 10) " 10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1362 (Assert (string= (format "% d" -10) "-10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1363 (Assert (string= (format "% 4d" 10) " 10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1364 (Assert (string= (format "% 4d" -10) " -10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1365 (Assert (string= (format "%0d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1366 (Assert (string= (format "%0d" -10) "-10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1367 (Assert (string= (format "%04d" 10) "0010"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1368 (Assert (string= (format "%04d" -10) "-010"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1369 (Assert (string= (format "%*d" 4 10) " 10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1370 (Assert (string= (format "%*d" 4 -10) " -10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1371 (Assert (string= (format "%*d" -4 10) "10 "))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1372 (Assert (string= (format "%*d" -4 -10) "-10 "))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1373 (Assert (string= (format "%#d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1374 (Assert (string= (format "%#o" 8) "010"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1375 (Assert (string= (format "%#x" 16) "0x10"))
826 6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1376 (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	1377 (string= (format "%#e" 100) "1.000000e+002")))
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1378 (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	1379 (string= (format "%#E" 100) "1.000000E+002")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1380 (Assert (string= (format "%#f" 100) "100.000000"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1381 (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	1382 (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	1383 (string= (format "%#g" 0.000001) "1.00000e-006")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1384 (Assert (string= (format "%#g" 0.0001) "0.000100000"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1385 (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	1386 (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	1387 (string= (format "%#G" 0.000001) "1.00000E-006")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1388 (Assert (string= (format "%#G" 0.0001) "0.000100000"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1389 (Assert (string= (format "%.1d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1390 (Assert (string= (format "%.4d" 10) "0010"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1391 ;; Combination of `-', `+', ` ', `0', `#', `.', `*'
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1392 (Assert (string= (format "%-04d" 10) "10 "))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1393 (Assert (string= (format "%-*d" 4 10) "10 "))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1394 ;; #### Correctness of this behavior is questionable.
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1395 ;; It might be better to signal error.
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1396 (Assert (string= (format "%-*d" -4 10) "10 "))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1397 ;; These behavior is not specified.
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1398 ;; (format "%-+d" 10)
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1399 ;; (format "%- d" 10)
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1400 ;; (format "%-01d" 10)
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1401 ;; (format "%-#4x" 10)
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1402 ;; (format "%-.1d" 10)
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1403
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1404 (Assert (string= (format "%01.1d" 10) "10"))
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1405 (Assert (string= (format "%03.1d" 10) " 10"))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1406 (Assert (string= (format "%01.3d" 10) "010"))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1407 (Assert (string= (format "%1.3d" 10) "010"))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1408 (Assert (string= (format "%3.1d" 10) " 10"))
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1409
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1410 ;;; The following two tests used to use 1000 instead of 100,
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1411 ;;; 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	1412 (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	1413 (Assert (= 100 (length (format "%100f" 3.14))))
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1414
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1415 ;;; 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	1416 (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	1417 (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	1418 (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	1419 (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	1420 (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	1421 (Assert (= (read (format "%ld" most-negative-fixnum)) most-negative-fixnum))
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1422
4287 89e64783d068 [xemacs-hg @ 2007-11-27 13:51:03 by aidan] aidan parents: 2075 diff changeset	1423 ;; 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	1424 (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	1425 (Assert (eql (read (format "%.1000d" 1)) 1))
4287 89e64783d068 [xemacs-hg @ 2007-11-27 13:51:03 by aidan] aidan parents: 2075 diff changeset	1426
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1427 ;;; "%u" is undocumented, and Emacs Lisp has no unsigned type.
1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1428 ;;; 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	1429 ;;; 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	1430 ;;; 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	1431 ;;; to Emacs Lisp.
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	1432 ;;; 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	1433 (if (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	1434 (progn
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	1435 (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	1436 (Check-Error wrong-type-argument (format "%u" -1)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	1437 (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	1438 (Check-Error invalid-read-syntax (read (format "%u" -1))))
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1439
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1440 ;; Check all-completions ignore element start with space.
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1441 (Assert (not (all-completions "" '((" hidden" . "object")))))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1442 (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	1443
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1444 (let* ((literal-with-uninterned
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1445 '(first-element
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1446 [#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	1447 #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	1448 #5=#:G32970 #6=#:G32972]))
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1449 (print-readably t)
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1450 (print-gensym t)
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1451 (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	1452 (awkward-regexp "#1=#")
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1453 (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	1454 printed-with-uninterned)))
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1455 (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	1456 (1+ first-match-start)))))
4580 1d11ecca9cd0 Print char table values correctly. Aidan Kehoe <kehoea@parhasard.net> parents: 4575 diff changeset	1457
1d11ecca9cd0 Print char table values correctly. Aidan Kehoe <kehoea@parhasard.net> parents: 4575 diff changeset	1458 (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	1459 (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	1460 (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	1461 (prin1-to-string char-table-with-symbol)))
4580 1d11ecca9cd0 Print char table values correctly. Aidan Kehoe <kehoea@parhasard.net> parents: 4575 diff changeset	1462 "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	1463
4608 1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1464
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1465 (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	1466 (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	1467 nil ".el")))
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1468 (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	1469 (erase-buffer)
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1470 (insert
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1471 "\
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1472 ;; 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	1473 ;; 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	1474 (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	1475
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1476 ;; 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	1477 (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	1478 old-char)
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1479 (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	1480 (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	1481 (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	1482 (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	1483 (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	1484 \"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	1485
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1486 (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	1487 (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	1488 (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	1489 \"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	1490
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1491 ")
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1492 (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	1493 (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	1494 (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	1495 (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	1496 (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	1497
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1498 (flet ((cl-floor (x &optional y)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1499 (let ((q (floor x y)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1500 (list q (- x (if y (* y q) q)))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1501 (cl-ceiling (x &optional y)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1502 (let ((res (cl-floor x y)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1503 (if (= (car (cdr res)) 0) res
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1504 (list (1+ (car res)) (- (car (cdr res)) (or y 1))))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1505 (cl-truncate (x &optional y)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1506 (if (eq (>= x 0) (or (null y) (>= y 0)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1507 (cl-floor x y) (cl-ceiling x y)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1508 (cl-round (x &optional y)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1509 (if y
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1510 (if (and (integerp x) (integerp y))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1511 (let* ((hy (/ y 2))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1512 (res (cl-floor (+ x hy) y)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1513 (if (and (= (car (cdr res)) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1514 (= (+ hy hy) y)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1515 (/= (% (car res) 2) 0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1516 (list (1- (car res)) hy)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1517 (list (car res) (- (car (cdr res)) hy))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1518 (let ((q (round (/ x y))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1519 (list q (- x (* q y)))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1520 (if (integerp x) (list x 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1521 (let ((q (round x)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1522 (list q (- x q))))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1523 (Assert-rounding (first second &key
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1524 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	1525 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	1526 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	1527 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	1528 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	1529 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	1530 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	1531 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	1532 (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	1533 (floor first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1534 (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	1535 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	1536 (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	1537 (floor first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1538 (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	1539 first one-floor-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1540 (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	1541 (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	1542 (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	1543 (floor first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1544 (format
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1545 "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	1546 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	1547 (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	1548 (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	1549 (format
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1550 "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	1551 first second))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1552 (Assert (equal one-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	1553 (ffloor first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1554 (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	1555 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	1556 (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	1557 (ffloor first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1558 (format "checking (ffloor %S 1) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1559 first one-ffloor-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1560 (Check-Error arith-error (ffloor first 0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1561 (Check-Error arith-error (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	1562 (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	1563 (ffloor first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1564 (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	1565 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	1566 (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	1567 (ceiling first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1568 (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	1569 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	1570 (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	1571 (ceiling first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1572 (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	1573 first one-ceiling-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1574 (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	1575 (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	1576 (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	1577 (ceiling first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1578 (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	1579 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	1580 (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	1581 (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	1582 (format
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1583 "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	1584 first second))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1585 (Assert (equal one-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	1586 (fceiling first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1587 (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	1588 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	1589 (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	1590 (fceiling first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1591 (format "checking (fceiling %S 1) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1592 first one-fceiling-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1593 (Check-Error arith-error (fceiling first 0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1594 (Check-Error arith-error (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	1595 (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	1596 (fceiling first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1597 (format "checking (fceiling %S %S) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1598 first second two-fceiling-result))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1599 (Assert (equal one-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	1600 (round first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1601 (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	1602 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	1603 (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	1604 (round first 1)))
4686 cdabd56ce1b5 Fix various small issues with the multiple-value implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 4679 diff changeset	1605 (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	1606 first one-round-result))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1607 (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	1608 (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	1609 (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	1610 (round first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1611 (format "checking (round %S %S) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1612 first second two-round-result))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1613 (Assert (equal 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	1614 (fround first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1615 (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	1616 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	1617 (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	1618 (fround first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1619 (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	1620 first one-fround-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1621 (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	1622 (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	1623 (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	1624 (fround first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1625 (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	1626 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	1627 (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	1628 (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	1629 (format
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1630 "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	1631 first second))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1632 (Assert (equal one-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	1633 (truncate first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1634 (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	1635 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	1636 (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	1637 (truncate first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1638 (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	1639 first one-truncate-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1640 (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	1641 (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	1642 (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	1643 (truncate first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1644 (format "checking (truncate %S %S) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1645 first second two-truncate-result))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1646 (Assert (equal (cl-truncate first second)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1647 (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	1648 (format
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1649 "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	1650 first second))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1651 (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	1652 (ftruncate first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1653 (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	1654 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	1655 (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	1656 (ftruncate first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1657 (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	1658 first one-ftruncate-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1659 (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	1660 (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	1661 (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	1662 (ftruncate first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1663 (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	1664 first second two-ftruncate-result)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1665 (Assert-rounding-floating (pie ee)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1666 (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	1667 (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	1668 "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	1669 (Assert-rounding pie ee
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1670 :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	1671 :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	1672 :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	1673 :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	1674 :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	1675 :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	1676 :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	1677 :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	1678 :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	1679 :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	1680 :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	1681 :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	1682 :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	1683 :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	1684 :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	1685 :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	1686 (- pie (* 1.0 ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1687 (Assert-rounding pie (- ee)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1688 :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	1689 :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	1690 :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	1691 :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	1692 (- pie (* -2.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1693 :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	1694 :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	1695 :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	1696 :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	1697 (- pie (* -1.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1698 :one-round-result (list 3 (- pie 3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1699 :two-round-result (list -1 (- pie (* -1 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1700 :one-fround-result (list (coerce 3 pie-type) (- pie 3.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1701 :two-fround-result (list (coerce -1 pie-type)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1702 (- pie (* -1.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1703 :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	1704 :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	1705 :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	1706 :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	1707 (- pie (* -1.0 (- ee)))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1708 (Assert-rounding (- pie) ee
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1709 :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	1710 :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	1711 :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	1712 :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	1713 (- (- pie) (* -2.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 -3 (- (- pie) -3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1715 :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	1716 :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	1717 :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	1718 (- (- pie) (* -1.0 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1719 :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	1720 :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	1721 :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	1722 :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	1723 (- (- pie) (* -1.0 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1724 :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	1725 :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	1726 :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	1727 :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	1728 (- (- pie) (* -1.0 ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1729 (Assert-rounding (- pie) (- ee)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1730 :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	1731 :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	1732 :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	1733 :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	1734 (- (- pie) (* 1.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1735 :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	1736 :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	1737 :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	1738 :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	1739 (- (- pie) (* 2.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1740 :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	1741 :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	1742 :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	1743 :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	1744 (- (- pie) (* 1.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1745 :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	1746 :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	1747 :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	1748 :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	1749 (- (- pie) (* 1.0 (- ee)))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1750 (Assert-rounding ee pie
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1751 :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	1752 :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	1753 :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	1754 :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	1755 :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	1756 :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	1757 :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	1758 :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	1759 :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	1760 :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	1761 :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	1762 :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	1763 :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	1764 :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	1765 :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	1766 :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	1767 (Assert-rounding ee (- pie)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1768 :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	1769 :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	1770 :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	1771 :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	1772 (- ee (* -1.0 (- pie))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1773 :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	1774 :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	1775 :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	1776 :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	1777 :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	1778 :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	1779 :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	1780 :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	1781 (- ee (* -1.0 (- pie))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1782 :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	1783 :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	1784 :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	1785 :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	1786 ;; First, two integers:
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1787 (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	1788 :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	1789 :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	1790 :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	1791 :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	1792 :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	1793 :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	1794 :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	1795 (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	1796 :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	1797 :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	1798 :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	1799 :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	1800 :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	1801 :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	1802 :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	1803 (Assert-rounding -27 8
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1804 :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	1805 :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	1806 :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	1807 :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	1808 :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	1809 :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	1810 :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	1811 :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	1812 (Assert-rounding -27 -8
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1813 :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	1814 :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	1815 :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	1816 :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	1817 :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	1818 :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	1819 :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	1820 :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	1821 (Assert-rounding 8 27
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1822 :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	1823 :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	1824 :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	1825 :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	1826 :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	1827 :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	1828 :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	1829 :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	1830 (Assert-rounding 8 -27
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1831 :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	1832 :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	1833 :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	1834 :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	1835 :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	1836 :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	1837 :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	1838 :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	1839 (Assert-rounding -8 27
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1840 :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	1841 :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	1842 :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	1843 :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	1844 :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	1845 :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	1846 :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	1847 :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	1848 (Assert-rounding -8 -27
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1849 :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	1850 :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	1851 :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	1852 :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	1853 :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	1854 :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	1855 :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	1856 :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	1857 (Assert-rounding 32 4
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1858 :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	1859 :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	1860 :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	1861 :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	1862 :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	1863 :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	1864 :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	1865 :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	1866 (Assert-rounding 32 -4
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1867 :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	1868 :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	1869 :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	1870 :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	1871 :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	1872 :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	1873 :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	1874 :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	1875 (Assert-rounding 12 9
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1876 :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	1877 :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	1878 :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	1879 :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	1880 :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	1881 :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	1882 :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	1883 :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	1884 (Assert-rounding 10 4
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1885 :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	1886 :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	1887 :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	1888 :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	1889 :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	1890 :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	1891 :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	1892 :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	1893 (Assert-rounding 14 4
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1894 :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	1895 :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	1896 :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	1897 :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	1898 :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	1899 :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	1900 :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	1901 :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	1902 ;; Now, two floats:
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1903 (Assert-rounding-floating pi e)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1904 (when (featurep 'bigfloat)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1905 (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	1906 (when (featurep 'bignum)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1907 (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	1908 "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	1909 (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	1910 :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	1911 :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	1912 :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	1913 :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	1914 :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	1915 :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	1916 :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	1917 :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	1918 :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	1919 :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	1920 :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	1921 :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	1922 :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	1923 :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	1924 :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	1925 :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	1926 (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	1927 :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	1928 :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	1929 :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	1930 :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	1931 :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	1932 :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	1933 :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	1934 :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	1935 :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	1936 :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	1937 :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	1938 :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	1939 :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	1940 :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	1941 :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	1942 :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	1943 (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	1944 :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	1945 :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	1946 :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	1947 :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	1948 :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	1949 :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	1950 :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	1951 :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	1952 :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	1953 :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	1954 :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	1955 :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	1956 :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	1957 :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	1958 :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	1959 :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	1960 ;; 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	1961 (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	1962 :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	1963 :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	1964 :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	1965 ;; 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	1966 ;; 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	1967 ;; 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	1968 ;; 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	1969 ;; 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	1970 :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	1971 :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	1972 :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	1973 :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	1974 :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	1975 :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	1976 :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	1977 :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	1978 :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	1979 :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	1980 :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	1981 :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	1982 ;; 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	1983 :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	1984 (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	1985 :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	1986 :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	1987 :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	1988 ;; 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	1989 :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	1990 :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	1991 :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	1992 :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	1993 :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	1994 :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	1995 :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	1996 :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	1997 :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	1998 :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	1999 :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	2000 :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	2001 ;; See commentary above
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2002 :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	2003 1)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2004 (when (featurep 'ratio)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2005 (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	2006 :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	2007 :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	2008 :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	2009 :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	2010 :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	2011 :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	2012 :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	2013 :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	2014 (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	2015 :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	2016 :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	2017 :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	2018 :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	2019 :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	2020 :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	2021 :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	2022 :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	2023
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2024 ;; 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	2025 ;; 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	2026 ;; 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	2027 ;; output here.
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2028
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2029 (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	2030 (let ((print-readably t))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2031 (princ first)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2032 (princ " ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2033 (princ second)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2034 (princ " :one-floor-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2035 (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	2036 (princ " :two-floor-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2037 (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	2038 (princ " :one-ffloor-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2039 (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	2040 (princ " :two-ffloor-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2041 (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	2042 (princ " :one-ceiling-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2043 (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	2044 (princ " :two-ceiling-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2045 (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	2046 (princ " :one-fceiling-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2047 (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	2048 (princ " :two-fceiling-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2049 (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	2050 (princ " :one-round-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2051 (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	2052 (princ " :two-round-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2053 (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	2054 (princ " :one-fround-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2055 (princ (list 'quote (multiple-value-list (fround first))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2056 (princ " :two-fround-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2057 (princ (list 'quote (multiple-value-list (fround first second))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2058 (princ " :one-truncate-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2059 (princ (list 'quote (multiple-value-list (truncate first))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2060 (princ " :two-truncate-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2061 (princ (list 'quote (multiple-value-list (truncate first second))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2062 (princ " :one-ftruncate-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2063 (princ (list 'quote (multiple-value-list (ftruncate first))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2064 (princ " :two-ftruncate-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2065 (princ (list 'quote (multiple-value-list (ftruncate first second))))))
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2066
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2067 ;; Multiple value tests.
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2068
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2069 (flet ((foo (x y)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2070 (floor (+ x y) y))
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2071 (foo-zero (x y)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2072 (values (floor (+ x y) y)))
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2073 (multiple-value-function-returning-t ()
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2074 (values t pi e degrees-to-radians radians-to-degrees))
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2075 (multiple-value-function-returning-nil ()
4686 cdabd56ce1b5 Fix various small issues with the multiple-value implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 4679 diff changeset	2076 (values nil pi e radians-to-degrees degrees-to-radians))
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2077 (function-throwing-multiple-values ()
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2078 (let* ((listing '(0 3 4 nil "string" symbol))
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2079 (tail listing)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2080 elt)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2081 (while t
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2082 (setq tail (cdr listing)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2083 elt (car listing)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2084 listing tail)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2085 (when (null elt)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2086 (throw 'VoN61Lo4Y (multiple-value-function-returning-t)))))))
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2087 (Assert
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2088 (= (+ (floor 5 3) (floor 19 4)) (+ 1 4) 5)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2089 "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	2090 (Assert
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2091 (= 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	2092 "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	2093 (Assert
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2094 (= 1 (length (multiple-value-list
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2095 (foo-zero 400 (1+ most-positive-fixnum)))))
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2096 "Checking multiple values are discarded correctly when forced")
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2097 (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	2098 (Assert (equal '(-1 1)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2099 (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	2100 "Checking #'multiple-value-list gives a sane result")
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2101 (let ((ey 40000)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2102 (bee "this is a string")
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2103 (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	2104 (Assert (equal
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2105 (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	2106 (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	2107 "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	2108 (Assert (equal
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2109 (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	2110 (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	2111 "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	2112 (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	2113 "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	2114 (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	2115 "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	2116 (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	2117 "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	2118 (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	2119 (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	2120 "Checking #'multiple-value-prog1 passes back multiple values")
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2121 (multiple-value-bind (floored remainder this-is-nil)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2122 (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	2123 (Assert (= floored 3)
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2124 "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	2125 (Assert (eql remainder (- pi 3.0))
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2126 "Checking remainder bound correctly")
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2127 (Assert (null this-is-nil)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2128 "Checking trailing arg bound but nil"))
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2129 (let ((ey 40000)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2130 (bee "this is a string")
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2131 (cee #s(hash-table size 256 data (969 ?\xF9))))
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2132 (multiple-value-setq (ey bee cee)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2133 (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	2134 (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	2135 (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	2136 (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	2137 (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	2138 "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	2139 (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	2140 "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	2141 (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	2142 "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	2143 (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	2144 (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	2145 "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	2146 (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	2147 (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	2148 "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	2149 (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	2150 (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	2151 "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	2152 (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	2153 (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	2154 "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	2155 (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	2156 (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	2157 "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	2158 (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	2159 (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	2160 "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	2161 (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	2162 (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2163 (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	2164 "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	2165 (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	2166 (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	2167 "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	2168 (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	2169 (multiple-value-prog1
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2170 (multiple-value-function-returning-nil)))))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2171 "Checking multiple-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	2172 (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	2173 (multiple-value-list
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2174 (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	2175 (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	2176 (multiple-value-list
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2177 (loop
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2178 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	2179 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	2180 (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	2181 "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	2182 (Assert
cdabd56ce1b5 Fix various small issues with the multiple-value implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 4679 diff changeset	2183 (null (or))
cdabd56ce1b5 Fix various small issues with the multiple-value implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 4679 diff changeset	2184 "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	2185 (Assert (eq t (and))
4686 cdabd56ce1b5 Fix various small issues with the multiple-value implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 4679 diff changeset	2186 "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	2187 (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	2188 (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	2189 (* 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	2190 "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	2191
4792 95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2192 ;; #'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	2193 (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	2194 (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	2195 (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	2196 (+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	2197 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	2198 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	2199 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	2200 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	2201 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	2202
5188 000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2203 (macrolet
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2204 ((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	2205 (let (res)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2206 (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	2207 (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	2208 (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	2209 (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	2210 (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	2211 ,(quote-maybe y))) res)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2212 (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	2213 ,(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	2214 (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	2215 (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	2216 res))))
5188 000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2217 (cons 'progn (nreverse res))))
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2218 (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	2219 (let (res)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2220 (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	2221 (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	2222 (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	2223 (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	2224 ,(quote-maybe y)))) res)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2225 (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	2226 ,(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	2227 (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	2228 (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	2229 `(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	2230 (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	2231 ,@(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	2232 (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	2233 (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	2234 (equalp-equal-list-tests
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2235 `(,@(when (featurep 'bignum)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2236 (read "((111111111111111111111111111111111111111111111111111
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2237 111111111111111111111111111111111111111111111111111.0))"))
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2238 (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	2239 (21845 #b101010101010101 #x5555)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2240 (1.5 1.500000000000000000000000000000000000000000000000000000000
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2241 ,@(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	2242 ;; 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	2243 ;;(-12345678901234567890123457890123457890123457890123457890123457890
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2244 ;; -12345678901234567890123457890123457890123457890123457890123457890.0)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2245 (-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	2246 (equalp-diff-list-tests
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2247 `(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	2248 ,@(when (featurep 'bignum)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2249 (read "(5555555555555555555555555555555555555
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2250 -5555555555555555555555555555555555555)"))
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2251 -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	2252 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	2253 ,@(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	2254 55555555555555555555555555555555555555555/2718281828459045
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2255 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	2256 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	2257
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	2258 (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	2259 "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	2260 (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	2261 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	2262 "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	2263 (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	2264 "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	2265 ;; 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	2266 (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	2267 "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	2268 (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	2269 "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	2270 "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	2271 (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	2272 "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	2273 "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	2274 (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	2275 "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	2276 (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	2277 "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	2278 (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	2279 "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	2280 (Assert-equalp
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2281 (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	2282 "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	2283 (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	2284 "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	2285 (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	2286 (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	2287 (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	2288 "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	2289 (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	2290 [?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	2291 (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	2292 "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	2293 (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	2294 (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	2295 "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	2296 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	2297 (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	2298 (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	2299 "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	2300 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	2301 (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	2302 (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	2303 "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	2304 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	2305 (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	2306 "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	2307 (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	2308 "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	2309 (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	2310 "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	2311 (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	2312 "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	2313 (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	2314 (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	2315 (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	2316 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	2317 "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	2318 (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	2319 (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	2320 (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	2321 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	2322 "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	2323 (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	2324 (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	2325 (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	2326 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	2327 "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	2328
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2329 ;; 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	2330 ;;
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2331 ;; 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	2332 ;;
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2333 ;; 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	2334 ;; 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	2335 ;; 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	2336 ;; 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	2337 ;; 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	2338 ;; 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	2339
4795 084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2340 (loop
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2341 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	2342 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	2343 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	2344 do
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2345 (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	2346 (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	2347 (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	2348 (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	2349 (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	2350 (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	2351 (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	2352 (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	2353
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2354 (loop
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2355 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	2356 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	2357 (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	2358
4885 6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2359 ;; #'member, #'assoc tests.
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2360
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2361 (when (featurep 'bignum)
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2362 (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	2363 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	2364 (assoc*-list (loop
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2365 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	2366 collect (cons elt (random))))
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2367 (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	2368 hashed-bignum)
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2369 (macrolet
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2370 ((1+most-positive-fixnum ()
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2371 (1+ most-positive-fixnum))
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2372 (1-most-negative-fixnum ()
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2373 (1- most-negative-fixnum))
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2374 (*-2-most-positive-fixnum ()
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2375 (* 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	2376 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2377 (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	2378 (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	2379 "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	2380 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2381 (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	2382 (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	2383 "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	2384 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2385 (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	2386 (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	2387 "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	2388 (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	2389 "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	2390 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2391 (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	2392 (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	2393 "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	2394 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2395 (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	2396 (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	2397 "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	2398 (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	2399 (gensym) hashing)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2400 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2401 (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	2402 (gethash hashed-bignum hashing))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2403 "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	2404
5241 d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2405 ;;
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2406 (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	2407 (Check-Error
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2408 invalid-state
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2409 (let ((str "aaaaaaaaaaaaa")
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2410 (called 0)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2411 modified)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2412 (reduce #'+ str
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2413 :key #'(lambda (object)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2414 (prog1
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2415 object
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2416 (incf called)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2417 (or modified
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2418 (and (> called 5)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2419 (setq modified
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2420 (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	2421
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2422 (Assert
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2423 (eql 55
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2424 (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	2425 (called 0)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2426 modified)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2427 (reduce #'+
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2428 sequence
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2429 :key
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2430 #'(lambda (object) (prog1
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2431 object
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2432 (incf called)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2433 (and (eql called 5)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2434 (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	2435 (garbage-collect))))))
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2436 "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	2437
5244 04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2438 (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	2439 `(((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	2440 ((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	2441 "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	2442
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2443 (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	2444 `(((mswindows) . [nothing])
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2445 ((tty) . [string :data " "]))
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2446 'image t)))
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2447 "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	2448
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2449 (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	2450 (canonicalize-inst-list
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2451 `(((,(gensym)) . [nothing])
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2452 ((tty) . [string :data " "]))
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2453 'image))
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2454
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2455 (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	2456 (canonicalize-inst-list
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2457 `(((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	2458 ((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	2459
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2460 ;; 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	2461 ;; 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	2462 ;; 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	2463 ;; 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	2464 ;; 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	2465 ;; 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	2466
5243 808131ba4a57 Print symbols with ratio-like names and the associated ratios distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5241 diff changeset	2467 (when (featurep 'ratio)
808131ba4a57 Print symbols with ratio-like names and the associated ratios distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5241 diff changeset	2468 (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	2469 "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	2470 (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	2471 "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	2472
5283 be436ac36ba4 Don't share a counter when checking for circularity, list_merge(). Aidan Kehoe <kehoea@parhasard.net> parents: 5244 diff changeset	2473 (let* ((count 0)
be436ac36ba4 Don't share a counter when checking for circularity, list_merge(). Aidan Kehoe <kehoea@parhasard.net> parents: 5244 diff changeset	2474 (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	2475 (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	2476 (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	2477 "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	2478
4732 2491a837112c Fix typo in test of equalp and add more tests. Stephen J. Turnbull <stephen@xemacs.org> parents: 4728 diff changeset	2479 ;;; end of lisp-tests.el

Mercurial > hg > xemacs-beta

annotate tests/automated/lisp-tests.el @ 5420:b9167d522a9a