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

annotate tests/automated/lisp-tests.el @ 5915:1af53d35dd53

Avoid allocation in #'integer-length; add #'logcount. lisp/ChangeLog addition: 2015-05-29 Aidan Kehoe <kehoea@parhasard.net> * byte-optimize.el (side-effect-free-fns): Add #'integer-length, #'logcount here. * cl-extra.el: * cl-extra.el (integer-length): Update this to avoid allocating memory. * cl-extra.el (logcount): New. Return the number of one bits in INTEGER, if non-negative. Function from Common Lisp. tests/ChangeLog addition: 2015-05-29 Aidan Kehoe <kehoea@parhasard.net> * automated/lisp-tests.el: Test #'integer-length, #'logcount in this file.

author	Aidan Kehoe <kehoea@parhasard.net>
date	Fri, 29 May 2015 17:06:24 +0100
parents	47ffa085a9ad
children	ffb5abc8dc4e

rev	line source
5035 b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1 ;; Copyright (C) 1998 Free Software Foundation, Inc. -- coding: iso-8859-1 --
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2 ;; Copyright (C) 2010 Ben Wing.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	3
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	4 ;; Author: Martin Buchholz <martin@xemacs.org>
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	5 ;; Maintainer: Martin Buchholz <martin@xemacs.org>
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	6 ;; Created: 1998
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	7 ;; Keywords: tests
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	8
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	9 ;; This file is part of XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	10
5402 308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	11 ;; XEmacs is free software: you can redistribute it and/or modify it
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	12 ;; under the terms of the GNU General Public License as published by the
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	13 ;; Free Software Foundation, either version 3 of the License, or (at your
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	14 ;; option) any later version.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	15
5402 308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	16 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	17 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	18 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	19 ;; for more details.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	20
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	21 ;; You should have received a copy of the GNU General Public License
5402 308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	22 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	23
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	24 ;;; Synched up with: Not in FSF.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	25
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	26 ;;; Commentary:
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	27
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	28 ;;; Test basic Lisp engine functionality
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	29 ;;; See test-harness.el for instructions on how to run these tests.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	30
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	31 (eval-when-compile
5772 cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	32 ;; The labels below give trouble with a max-lisp-eval-depth of less than
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	33 ;; about 2000, work around that:
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	34 (setq max-lisp-eval-depth (max 2000 max-lisp-eval-depth))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	35 (condition-case nil
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	36 (require 'test-harness)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	37 (file-error
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	38 (push "." load-path)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	39 (when (and (boundp 'load-file-name) (stringp load-file-name))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	40 (push (file-name-directory load-file-name) load-path))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	41 (require 'test-harness))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	42
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	43 (Check-Error wrong-number-of-arguments (setq setq-test-foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	44 (Check-Error wrong-number-of-arguments (setq setq-test-foo 1 setq-test-bar))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	45 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	46 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo 1 setq-test-bar))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	47 (Assert (eq (setq) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	48 (Assert (eq (setq-default) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	49 (Assert (eq (setq setq-test-foo 42) 42))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	50 (Assert (eq (setq-default setq-test-foo 42) 42))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	51 (Assert (eq (setq setq-test-foo 42 setq-test-bar 99) 99))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	52 (Assert (eq (setq-default setq-test-foo 42 setq-test-bar 99) 99))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	53
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	54 (macrolet ((test-setq (expected-result &rest body)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	55 `(progn
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	56 (defun test-setq-fun () ,@body)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	57 (Assert (eq ,expected-result (test-setq-fun)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	58 (byte-compile 'test-setq-fun)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	59 (Assert (eq ,expected-result (test-setq-fun))))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	60 (test-setq nil (setq))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	61 (test-setq nil (setq-default))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	62 (test-setq 42 (setq test-setq-var 42))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	63 (test-setq 42 (setq-default test-setq-var 42))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	64 (test-setq 42 (setq test-setq-bar 99 test-setq-var 42))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	65 (test-setq 42 (setq-default test-setq-bar 99 test-setq-var 42))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	66 )
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	67
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	68 (let ((my-vector [1 2 3 4])
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	69 (my-bit-vector (bit-vector 1 0 1 0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	70 (my-string "1234")
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	71 (my-list '(1 2 3 4)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	72
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	73 ;;(Assert (fooooo)) ;; Generate Other failure
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	74 ;;(Assert (eq 1 2)) ;; Generate Assertion failure
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	75
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	76 (dolist (sequence (list my-vector my-bit-vector my-string my-list))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	77 (Assert (sequencep sequence))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	78 (Assert (eq 4 (length sequence))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	79
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	80 (dolist (array (list my-vector my-bit-vector my-string))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	81 (Assert (arrayp array)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	82
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	83 (Assert (eq (elt my-vector 0) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	84 (Assert (eq (elt my-bit-vector 0) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	85 (Assert (eq (elt my-string 0) ?1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	86 (Assert (eq (elt my-list 0) 1))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	87
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	88 (fillarray my-vector 5)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	89 (fillarray my-bit-vector 1)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	90 (fillarray my-string ?5)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	91
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	92 (dolist (array (list my-vector my-bit-vector))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	93 (Assert (eq 4 (length array))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	94
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	95 (Assert (eq (elt my-vector 0) 5))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	96 (Assert (eq (elt my-bit-vector 0) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	97 (Assert (eq (elt my-string 0) ?5))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	98
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	99 (Assert (eq (elt my-vector 3) 5))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	100 (Assert (eq (elt my-bit-vector 3) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	101 (Assert (eq (elt my-string 3) ?5))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	102
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	103 (fillarray my-bit-vector 0)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	104 (Assert (eq 4 (length my-bit-vector)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	105 (Assert (eq (elt my-bit-vector 2) 0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	106 )
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	107
5772 cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	108 (defun make-circular-list (length &optional value)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	109 "Create evil emacs-crashing circular list of length LENGTH.
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	110
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	111 Optional VALUE is the value to go into the cars. If nil, some non-nil value
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	112 will be used to make debugging easier."
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	113 (let ((circular-list
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	114 (make-list
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	115 length
5772 cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	116 (or value
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	117 'you-are-trapped-in-a-twisty-maze-of-cons-cells-all-alike))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	118 (setcdr (last circular-list) circular-list)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	119 circular-list))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	120
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	121 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	122 ;; Test `nconc'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	123 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	124 (defun make-list-012 () (list 0 1 2))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	125
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	126 (Check-Error wrong-type-argument (nconc 'foo nil))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	127
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	128 (dolist (length '(1 2 3 4 1000 2000))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	129 (Check-Error circular-list (nconc (make-circular-list length) 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	130 (Check-Error circular-list (nconc '(1 . 2) (make-circular-list length) 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	131 (Check-Error circular-list (nconc '(1 . 2) '(3 . 4) (make-circular-list length) 'foo)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	132
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	133 (Assert (eq (nconc) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	134 (Assert (eq (nconc nil) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	135 (Assert (eq (nconc nil nil) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	136 (Assert (eq (nconc nil nil nil) nil))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	137
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	138 (let ((x (make-list-012))) (Assert (eq (nconc nil x) x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	139 (let ((x (make-list-012))) (Assert (eq (nconc x nil) x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	140 (let ((x (make-list-012))) (Assert (eq (nconc nil x nil) x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	141 (let ((x (make-list-012))) (Assert (eq (nconc x) x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	142 (let ((x (make-list-012))) (Assert (eq (nconc x (make-circular-list 3)) x)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	143
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	144 (Assert (equal (nconc '(1 . 2) '(3 . 4) '(5 . 6)) '(1 3 5 . 6)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	145
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	146 (let ((y (nconc (make-list-012) nil (list 3 4 5) nil)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	147 (Assert (eq (length y) 6))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	148 (Assert (eq (nth 3 y) 3)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	149
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	150 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	151 ;; Test `last'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	152 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	153 (Check-Error wrong-type-argument (last 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	154 (Check-Error wrong-number-of-arguments (last))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	155 (Check-Error wrong-number-of-arguments (last '(1 2) 1 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	156 (Check-Error circular-list (last (make-circular-list 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	157 (Check-Error circular-list (last (make-circular-list 2000)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	158 (let ((x (list 0 1 2 3)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	159 (Assert (eq (last nil) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	160 (Assert (eq (last x 0) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	161 (Assert (eq (last x ) (cdddr x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	162 (Assert (eq (last x 1) (cdddr x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	163 (Assert (eq (last x 2) (cddr x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	164 (Assert (eq (last x 3) (cdr x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	165 (Assert (eq (last x 4) x))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	166 (Assert (eq (last x 9) x))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	167 (Assert (eq (last '(1 . 2) 0) 2))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	168 )
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	169
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	170 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	171 ;; Test `butlast' and `nbutlast'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	172 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	173 (Check-Error wrong-type-argument (butlast 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	174 (Check-Error wrong-type-argument (nbutlast 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	175 (Check-Error wrong-number-of-arguments (butlast))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	176 (Check-Error wrong-number-of-arguments (nbutlast))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	177 (Check-Error wrong-number-of-arguments (butlast '(1 2) 1 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	178 (Check-Error wrong-number-of-arguments (nbutlast '(1 2) 1 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	179 (Check-Error circular-list (butlast (make-circular-list 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	180 (Check-Error circular-list (nbutlast (make-circular-list 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	181 (Check-Error circular-list (butlast (make-circular-list 2000)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	182 (Check-Error circular-list (nbutlast (make-circular-list 2000)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	183
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	184 (let* ((x (list 0 1 2 3))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	185 (y (butlast x))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	186 (z (nbutlast x)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	187 (Assert (eq z x))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	188 (Assert (not (eq y x)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	189 (Assert (equal y '(0 1 2)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	190 (Assert (equal z y)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	191
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	192 (let* ((x (list 0 1 2 3 4))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	193 (y (butlast x 2))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	194 (z (nbutlast x 2)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	195 (Assert (eq z x))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	196 (Assert (not (eq y x)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	197 (Assert (equal y '(0 1 2)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	198 (Assert (equal z y)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	199
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	200 (let* ((x (list 0 1 2 3))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	201 (y (butlast x 0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	202 (z (nbutlast x 0)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	203 (Assert (eq z x))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	204 (Assert (not (eq y x)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	205 (Assert (equal y '(0 1 2 3)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	206 (Assert (equal z y)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	207
5285 99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	208 (let* ((x (list* 0 1 2 3 4 5 6.0 ?7 ?8 (vector 'a 'b 'c)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	209 (y (butlast x 0))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	210 (z (nbutlast x 0)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	211 (Assert (eq z x))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	212 (Assert (not (eq y x)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	213 (Assert (equal y '(0 1 2 3 4 5 6.0 ?7 ?8)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	214 (Assert (equal z y)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	215
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	216 (Assert (eq (butlast '(x)) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	217 (Assert (eq (nbutlast '(x)) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	218 (Assert (eq (butlast '()) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	219 (Assert (eq (nbutlast '()) nil))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	220
5307 c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	221 (when (featurep 'bignum)
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	222 (let* ((x (list* 0 1 2 3 4 5 6.0 ?7 ?8 (vector 'a 'b 'c)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	223 (y (butlast x (* 2 most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	224 (z (nbutlast x (* 3 most-positive-fixnum))))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	225 (Assert (eq nil y) "checking butlast with a large bignum gives nil")
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	226 (Assert (eq nil z) "checking nbutlast with a large bignum gives nil")
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	227 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	228 (nbutlast x (1- most-negative-fixnum))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	229 "checking nbutlast with a negative bignum errors")))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	230
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	231 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	232 ;; Test `copy-list'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	233 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	234 (Check-Error wrong-type-argument (copy-list 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	235 (Check-Error wrong-number-of-arguments (copy-list))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	236 (Check-Error wrong-number-of-arguments (copy-list '(1 2) 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	237 (Check-Error circular-list (copy-list (make-circular-list 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	238 (Check-Error circular-list (copy-list (make-circular-list 2000)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	239 (Assert (eq '() (copy-list '())))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	240 (dolist (x '((1) (1 2) (1 2 3) (1 2 . 3)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	241 (let ((y (copy-list x)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	242 (Assert (and (equal x y) (not (eq x y))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	243
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	244 ;;-----------------------------------------------------
5285 99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	245 ;; Test `ldiff'
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	246 ;;-----------------------------------------------------
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	247 (Check-Error wrong-type-argument (ldiff 'foo pi))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	248 (Check-Error wrong-number-of-arguments (ldiff))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	249 (Check-Error wrong-number-of-arguments (ldiff '(1 2)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	250 (Check-Error circular-list (ldiff (make-circular-list 1) nil))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	251 (Check-Error circular-list (ldiff (make-circular-list 2000) nil))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	252 (Assert (eq '() (ldiff '() pi)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	253 (dolist (x '((1) (1 2) (1 2 3) (1 2 . 3)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	254 (let ((y (ldiff x nil)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	255 (Assert (and (equal x y) (not (eq x y))))))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	256
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	257 (let* ((vector (vector 'foo))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	258 (dotted `(1 2 3 ,pi 40 50 . ,vector))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	259 (dotted-pi `(1 2 3 . ,pi))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	260 without-vector without-pi)
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	261 (Assert (equal dotted (ldiff dotted nil))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	262 "checking ldiff handles dotted lists properly")
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	263 (Assert (equal (butlast dotted 0) (ldiff dotted vector))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	264 "checking ldiff discards dotted elements correctly")
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	265 (Assert (equal (butlast dotted-pi 0) (ldiff dotted-pi (* 4 (atan 1))))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	266 "checking ldiff handles float equivalence correctly"))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	267
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	268 ;;-----------------------------------------------------
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	269 ;; Test `tailp'
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	270 ;;-----------------------------------------------------
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	271 (Check-Error wrong-type-argument (tailp pi 'foo))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	272 (Check-Error wrong-number-of-arguments (tailp))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	273 (Check-Error wrong-number-of-arguments (tailp '(1 2)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	274 (Check-Error circular-list (tailp nil (make-circular-list 1)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	275 (Check-Error circular-list (tailp nil (make-circular-list 2000)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	276 (Assert (null (tailp pi '()))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	277 "checking pi is not a tail of the list nil")
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	278 (Assert (tailp 3 '(1 2 . 3))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	279 "checking #'tailp works with a dotted integer.")
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	280 (Assert (tailp pi `(1 2 . ,(* 4 (atan 1))))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	281 "checking tailp works with non-eq dotted floats.")
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	282 (let ((list (make-list 2048 nil)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	283 (Assert (tailp (nthcdr 2000 list) (nconc list list))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	284 "checking #'tailp succeeds with circular LIST containing SUBLIST"))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	285
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	286 ;;-----------------------------------------------------
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	287 ;; Test `endp'
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	288 ;;-----------------------------------------------------
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	289 (Check-Error wrong-type-argument (endp 'foo))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	290 (Check-Error wrong-number-of-arguments (endp))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	291 (Check-Error wrong-number-of-arguments (endp '(1 2) 'foo))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	292 (Assert (endp nil) "checking nil is recognized as the end of a list")
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	293 (Assert (not (endp (list 200 200 4 0 9)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	294 "checking a cons is not recognised as the end of a list")
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	295
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	296 ;;-----------------------------------------------------
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	297 ;; Arithmetic operations
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	298 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	299
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	300 ;; Test `+'
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	301 (Assert (eq (+ 1 1) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	302 (Assert (= (+ 1.0 1.0) 2.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	303 (Assert (= (+ 1.0 3.0 0.0) 4.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	304 (Assert (= (+ 1 1.0) 2.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	305 (Assert (= (+ 1.0 1) 2.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	306 (Assert (= (+ 1.0 1 1) 3.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	307 (Assert (= (+ 1 1 1.0) 3.0))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	308 (if (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	309 (progn
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	310 (Assert (bignump (1+ most-positive-fixnum)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	311 (Assert (eq most-positive-fixnum (1- (1+ most-positive-fixnum))))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	312 (Assert (bignump (+ most-positive-fixnum 1)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	313 (Assert (eq most-positive-fixnum (- (+ most-positive-fixnum 1) 1)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	314 (Assert (= (1+ most-positive-fixnum) (- most-negative-fixnum)))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	315 (Assert (zerop (+ (* 3 most-negative-fixnum) (* 3 most-positive-fixnum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	316 3))))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	317 (Assert (eq (1+ most-positive-fixnum) most-negative-fixnum))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	318 (Assert (eq (+ most-positive-fixnum 1) most-negative-fixnum)))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	319
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	320 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	321 (let ((threefourths (read "3/4"))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	322 (threehalfs (read "3/2"))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	323 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	324 (bigneg (div (+ most-positive-fixnum 2) most-negative-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	325 (negone (div (1+ most-positive-fixnum) most-negative-fixnum)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	326 (Assert (= negone -1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	327 (Assert (= threehalfs (+ threefourths threefourths)))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	328 (Assert (zerop (+ bigpos bigneg)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	329
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	330 ;; Test `-'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	331 (Check-Error wrong-number-of-arguments (-))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	332 (Assert (eq (- 0) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	333 (Assert (eq (- 1) -1))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	334 (dolist (one `(1 1.0 ?\1 ,(Int-to-Marker 1)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	335 (Assert (= (+ 1 one) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	336 (Assert (= (+ one) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	337 (Assert (= (+ one) one))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	338 (Assert (= (- one) -1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	339 (Assert (= (- one one) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	340 (Assert (= (- one one one) -1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	341 (Assert (= (- 0 one) -1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	342 (Assert (= (- 0 one one) -2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	343 (Assert (= (+ one 1) 2))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	344 (dolist (zero '(0 0.0 ?\0))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	345 (Assert (= (+ 1 zero) 1) zero)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	346 (Assert (= (+ zero 1) 1) zero)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	347 (Assert (= (- zero) zero) zero)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	348 (Assert (= (- zero) 0) zero)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	349 (Assert (= (- zero zero) 0) zero)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	350 (Assert (= (- zero one one) -2) zero)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	351
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	352 (Assert (= (- 1.5 1) .5))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	353 (Assert (= (- 1 1.5) (- .5)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	354
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	355 (if (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	356 (progn
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	357 (Assert (bignump (1- most-negative-fixnum)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	358 (Assert (eq most-negative-fixnum (1+ (1- most-negative-fixnum))))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	359 (Assert (bignump (- most-negative-fixnum 1)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	360 (Assert (eq most-negative-fixnum (+ (- most-negative-fixnum 1) 1)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	361 (Assert (= (1- most-negative-fixnum) (- 0 most-positive-fixnum 2)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	362 (Assert (eq (- (- most-positive-fixnum most-negative-fixnum)
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	363 (* 2 most-positive-fixnum))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	364 1)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	365 (Assert (eq (1- most-negative-fixnum) most-positive-fixnum))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	366 (Assert (eq (- most-negative-fixnum 1) most-positive-fixnum)))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	367
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	368 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	369 (let ((threefourths (read "3/4"))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	370 (threehalfs (read "3/2"))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	371 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	372 (bigneg (div most-positive-fixnum most-negative-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	373 (negone (div (1+ most-positive-fixnum) most-negative-fixnum)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	374 (Assert (= (- negone) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	375 (Assert (= threefourths (- threehalfs threefourths)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	376 (Assert (= (- bigpos bigneg) 2))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	377
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	378 ;; Test `/'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	379
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	380 ;; Test division by zero errors
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	381 (dolist (zero '(0 0.0 ?\0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	382 (Check-Error arith-error (/ zero))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	383 (dolist (n1 `(42 42.0 ?\042 ,(Int-to-Marker 42)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	384 (Check-Error arith-error (/ n1 zero))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	385 (dolist (n2 `(3 3.0 ?\03 ,(Int-to-Marker 3)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	386 (Check-Error arith-error (/ n1 n2 zero)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	387
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	388 ;; Other tests for `/'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	389 (Check-Error wrong-number-of-arguments (/))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	390 (let (x)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	391 (Assert (= (/ (setq x 2)) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	392 (Assert (= (/ (setq x 2.0)) 0.5)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	393
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	394 (dolist (six '(6 6.0 ?\06))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	395 (dolist (two '(2 2.0 ?\02))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	396 (dolist (three '(3 3.0 ?\03))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	397 (Assert (= (/ six two) three) (list six two three)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	398
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	399 (dolist (three '(3 3.0 ?\03))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	400 (Assert (= (/ three 2.0) 1.5) three))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	401 (dolist (two '(2 2.0 ?\02))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	402 (Assert (= (/ 3.0 two) 1.5) two))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	403
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	404 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	405 (let* ((million 1000000)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	406 (billion (* million 1000)) ;; American, not British, billion
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	407 (trillion (* billion 1000)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	408 (Assert (= (/ billion 1000) (/ trillion million) million 1000000.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	409 (Assert (= (/ billion -1000) (/ trillion (- million)) (- million)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	410 (Assert (= (/ trillion 1000) billion 1000000000.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	411 (Assert (= (/ trillion -1000) (- billion) -1000000000.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	412 (Assert (= (/ trillion 10) (* 100 billion) 100000000000.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	413 (Assert (= (/ (- trillion) 10) (* -100 billion) -100000000000.0))))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	414
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	415 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	416 (let ((half (div 1 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	417 (fivefourths (div 5 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	418 (fivehalfs (div 5 2)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	419 (Assert (= half (read "3000000000/6000000000")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	420 (Assert (= (/ fivehalfs fivefourths) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	421 (Assert (= (/ fivefourths fivehalfs) half))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	422 (Assert (= (- half) (read "-3000000000/6000000000")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	423 (Assert (= (/ fivehalfs (- fivefourths)) -2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	424 (Assert (= (/ (- fivefourths) fivehalfs) (- half)))))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	425
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	426 ;; Test `*'
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	427 (Assert (= 1 (*)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	428
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	429 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	430 (Assert (= 1 (* one)) one))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	431
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	432 (dolist (two '(2 2.0 ?\02))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	433 (Assert (= 2 (* two)) two))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	434
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	435 (dolist (six '(6 6.0 ?\06))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	436 (dolist (two '(2 2.0 ?\02))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	437 (dolist (three '(3 3.0 ?\03))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	438 (Assert (= (* three two) six) (list three two six)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	439
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	440 (dolist (three '(3 3.0 ?\03))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	441 (dolist (two '(2 2.0 ?\02))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	442 (Assert (= (* 1.5 two) three) (list two three))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	443 (dolist (five '(5 5.0 ?\05))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	444 (Assert (= 30 (* five two three)) (list five two three)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	445
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	446 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	447 (let ((64K 65536))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	448 (Assert (= (* 64K 64K) (read "4294967296")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	449 (Assert (= (* (- 64K) 64K) (read "-4294967296")))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	450 (Assert (/= (* -1 most-negative-fixnum) most-negative-fixnum))))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	451
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	452 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	453 (let ((half (div 1 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	454 (fivefourths (div 5 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	455 (twofifths (div 2 5)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	456 (Assert (= (* fivefourths twofifths) half))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	457 (Assert (= (* half twofifths) (read "3/15")))))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	458
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	459 ;; Test `+'
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	460 (Assert (= 0 (+)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	461
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	462 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	463 (Assert (= 1 (+ one)) one))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	464
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	465 (dolist (two '(2 2.0 ?\02))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	466 (Assert (= 2 (+ two)) two))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	467
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	468 (dolist (five '(5 5.0 ?\05))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	469 (dolist (two '(2 2.0 ?\02))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	470 (dolist (three '(3 3.0 ?\03))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	471 (Assert (= (+ three two) five) (list three two five))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	472 (Assert (= 10 (+ five two three)) (list five two three)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	473
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	474 ;; Test `max', `min'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	475 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	476 (Assert (= one (max one)) one)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	477 (Assert (= one (max one one)) one)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	478 (Assert (= one (max one one one)) one)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	479 (Assert (= one (min one)) one)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	480 (Assert (= one (min one one)) one)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	481 (Assert (= one (min one one one)) one)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	482 (dolist (two `(2 2.0 ?\02 ,(Int-to-Marker 2)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	483 (Assert (= one (min one two)) (list one two))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	484 (Assert (= one (min one two two)) (list one two))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	485 (Assert (= one (min two two one)) (list one two))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	486 (Assert (= two (max one two)) (list one two))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	487 (Assert (= two (max one two two)) (list one two))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	488 (Assert (= two (max two two one)) (list one two))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	489
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	490 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	491 (let ((big (1+ most-positive-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	492 (small (1- most-negative-fixnum)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	493 (Assert (= big (max 1 1000000.0 most-positive-fixnum big)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	494 (Assert (= small (min -1 -1000000.0 most-negative-fixnum small)))))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	495
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	496 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	497 (let* ((big (1+ most-positive-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	498 (small (1- most-negative-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	499 (bigr (div (* 5 (1+ most-positive-fixnum)) 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	500 (smallr (- bigr)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	501 (Assert (= bigr (max 1 1000000.0 most-positive-fixnum big bigr)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	502 (Assert (= smallr (min -1 -1000000.0 most-negative-fixnum small smallr)))))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	503
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	504 ;; The byte compiler has special handling for these constructs:
1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	505 (let ((three 3) (five 5))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	506 (Assert (= (+ three five 1) 9))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	507 (Assert (= (+ 1 three five) 9))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	508 (Assert (= (+ three five -1) 7))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	509 (Assert (= (+ -1 three five) 7))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	510 (Assert (= (+ three 1) 4))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	511 (Assert (= (+ three -1) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	512 (Assert (= (+ -1 three) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	513 (Assert (= (+ -1 three) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	514 (Assert (= (- three five 1) -3))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	515 (Assert (= (- 1 three five) -7))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	516 (Assert (= (- three five -1) -1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	517 (Assert (= (- -1 three five) -9))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	518 (Assert (= (- three 1) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	519 (Assert (= (- three 2 1) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	520 (Assert (= (- 2 three 1) -2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	521 (Assert (= (- three -1) 4))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	522 (Assert (= (- three 0) 3))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	523 (Assert (= (- three 0 five) -2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	524 (Assert (= (- 0 three 0 five) -8))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	525 (Assert (= (- 0 three five) -8))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	526 (Assert (= (* three 2) 6))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	527 (Assert (= (* three -1 five) -15))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	528 (Assert (= (* three 1 five) 15))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	529 (Assert (= (* three 0 five) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	530 (Assert (= (* three 2 five) 30))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	531 (Assert (= (/ three 1) 3))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	532 (Assert (= (/ three -1) -3))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	533 (Assert (= (/ (* five five) 2 2) 6))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	534 (Assert (= (/ 64 five 2) 6)))
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	535
1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	536
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	537 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	538 ;; Logical bit-twiddling operations
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	539 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	540 (Assert (= (logxor) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	541 (Assert (= (logior) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	542 (Assert (= (logand) -1))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	543
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	544 (Check-Error wrong-type-argument (logxor 3.0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	545 (Check-Error wrong-type-argument (logior 3.0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	546 (Check-Error wrong-type-argument (logand 3.0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	547
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	548 (dolist (three '(3 ?\03))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	549 (Assert (eq 3 (logand three)) three)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	550 (Assert (eq 3 (logxor three)) three)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	551 (Assert (eq 3 (logior three)) three)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	552 (Assert (eq 3 (logand three three)) three)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	553 (Assert (eq 0 (logxor three three)) three)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	554 (Assert (eq 3 (logior three three))) three)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	555
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	556 (dolist (one `(1 ?\01 ,(Int-to-Marker 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	557 (dolist (two '(2 ?\02))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	558 (Assert (eq 0 (logand one two)) (list one two))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	559 (Assert (eq 3 (logior one two)) (list one two))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	560 (Assert (eq 3 (logxor one two)) (list one two)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	561 (dolist (three '(3 ?\03))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	562 (Assert (eq 1 (logand one three)) (list one three))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	563 (Assert (eq 3 (logior one three)) (list one three))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	564 (Assert (eq 2 (logxor one three)) (list one three))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	565
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	566 ;;-----------------------------------------------------
5915 1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	567 ;; Test `integer-length', `logcount'
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	568 ;;-----------------------------------------------------
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	569
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	570 (Check-Error wrong-type-argument (integer-length 0.0))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	571 (Check-Error wrong-type-argument (integer-length 'symbol))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	572 (Assert (eql (integer-length 0) 0))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	573 (Assert (eql (integer-length -1) 0))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	574 (Assert (eql (integer-length 1) 1))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	575 (Assert (eql (integer-length #x-F) 4))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	576 (Assert (eql (integer-length #xF) 4))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	577 (Assert (eql (integer-length #x-10) 4))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	578 (Assert (eql (integer-length #x10) 5))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	579
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	580 (Check-Error wrong-type-argument (logcount 0.0))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	581 (Check-Error wrong-type-argument (logcount 'symbol))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	582 (Assert (eql (logcount 0) 0))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	583 (Assert (eql (logcount 1) 1))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	584 (Assert (eql (logcount -1) 0))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	585 (Assert (eql (logcount #x-F) 3))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	586 (Assert (eql (logcount #xF) 4))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	587 (Assert (eql (logcount #x-10) 4))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	588 (Assert (eql (logcount #x10) 1))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	589
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	590 (macrolet
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	591 ((random-sample-n () 10) ;; Increase this to get a bigger sample.
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	592 (test-integer-length-random-sample ()
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	593 (cons
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	594 'progn
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	595 (loop for index from 0 to (random-sample-n)
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	596 nconc (let* ((value (random (if (featurep 'bignum)
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	597 (lsh most-positive-fixnum 4)
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	598 most-positive-fixnum)))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	599 (length (length (format "%b" value))))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	600 `((Assert (eql (integer-length ,value) ,length))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	601 (Assert (eql (integer-length ,(1- (- value)))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	602 ,length)))))))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	603 (test-logcount-random-sample ()
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	604 (cons
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	605 'progn
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	606 (loop for index from 0 to (random-sample-n)
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	607 nconc (let* ((value (random (if (featurep 'bignum)
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	608 (lsh most-positive-fixnum 4)
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	609 most-positive-fixnum)))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	610 (count (count ?1 (format "%b" value))))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	611 `((Assert (eql (logcount ,value) ,count))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	612 (Assert (eql (logcount ,(lognot value)) ,count))))))))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	613 (test-integer-length-random-sample)
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	614 (test-logcount-random-sample))
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	615
1af53d35dd53 Avoid allocation in #'integer-length; add #'logcount. Aidan Kehoe <kehoea@parhasard.net> parents: 5912 diff changeset	616 ;;-----------------------------------------------------
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	617 ;; Test `%', mod
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	618 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	619 (Check-Error wrong-number-of-arguments (%))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	620 (Check-Error wrong-number-of-arguments (% 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	621 (Check-Error wrong-number-of-arguments (% 1 2 3))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	622
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	623 (Check-Error wrong-number-of-arguments (mod))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	624 (Check-Error wrong-number-of-arguments (mod 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	625 (Check-Error wrong-number-of-arguments (mod 1 2 3))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	626
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	627 (Check-Error wrong-type-argument (% 10.0 2))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	628 (Check-Error wrong-type-argument (% 10 2.0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	629
5576 071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	630 (labels ((test1 (x) (Assert (eql x (+ (% x 17) (* (/ x 17) 17))) x))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	631 (test2 (x) (Assert (eql (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17))) x))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	632 (test3 (x) (Assert (eql x (+ (% (- x) 17) (* (/ (- x) 17) 17))) x))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	633 (test4 (x) (Assert (eql (% x -17) (- (% (- x) 17))) x))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	634 (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	635 (test1 most-negative-fixnum)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	636 (if (featurep 'bignum)
2075 c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james] james parents: 2056 diff changeset	637 (progn
c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james] james parents: 2056 diff changeset	638 (test2 most-negative-fixnum)
c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james] james parents: 2056 diff changeset	639 (test4 most-negative-fixnum))
c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james] james parents: 2056 diff changeset	640 (test3 most-negative-fixnum)
c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james] james parents: 2056 diff changeset	641 (test5 most-negative-fixnum))
2056 ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	642 (test1 most-positive-fixnum)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	643 (test2 most-positive-fixnum)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	644 (test4 most-positive-fixnum)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	645 (dotimes (j 30)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	646 (let ((x (random)))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	647 (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	648 (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	649 (test1 x)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	650 (test2 x)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	651 (test4 x))))
428 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 (macrolet
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	654 ((division-test (seven)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	655 `(progn
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	656 (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	657 (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	658 (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	659 (Assert (eq (% (- ,seven) -2) -1))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	660
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	661 (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	662 (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	663 (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	664 (Assert (eq (% (- ,seven) -4) -3))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	665
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	666 (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	667 (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	668 (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	669 (Assert (eq (% -35 (- ,seven)) 0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	670
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	671 (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	672 (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	673 (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	674 (Assert (eq (mod (- ,seven) -2) -1))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	675
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	676 (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	677 (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	678 (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	679 (Assert (eq (mod (- ,seven) -4) -3))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	680
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	681 (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	682 (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	683 (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	684 (Assert (eq (mod -35 (- ,seven)) 0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	685
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	686 (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	687 (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	688 (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	689 (Assert (= (mod (- ,seven) -2.0) -1.0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	690
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	691 (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	692 (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	693 (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	694 (Assert (= (mod (- ,seven) -4.0) -3.0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	695
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	696 (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	697 (Assert (eq (% 0 (- ,seven)) 0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	698
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	699 (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	700 (Assert (eq (mod 0 (- ,seven)) 0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	701
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	702 (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	703 (Assert (= (mod 0.0 (- ,seven)) 0.0)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	704
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	705 (division-test 7)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	706 (division-test ?\07)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	707 (division-test (Int-to-Marker 7)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	708
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	709 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	710 (let ((big (+ (* 7 most-positive-fixnum 6)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	711 (negbig (- (* 7 most-negative-fixnum 6))))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	712 (= (% big (1+ most-positive-fixnum)) most-positive-fixnum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	713 (= (% negbig (1- most-negative-fixnum)) most-negative-fixnum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	714 (= (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	715 (= (mod negbig (1- most-negative-fixnum)) most-negative-fixnum)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	716
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	717 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	718 ;; Arithmetic comparison operations
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 (Check-Error wrong-number-of-arguments (=))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	721 (Check-Error wrong-number-of-arguments (<))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	722 (Check-Error wrong-number-of-arguments (>))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	723 (Check-Error wrong-number-of-arguments (<=))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	724 (Check-Error wrong-number-of-arguments (>=))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	725 (Check-Error wrong-number-of-arguments (/=))
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 ;; One argument always yields t
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	728 (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	729 (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	730 (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	731 (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	732 (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	733 (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	734 (Assert (eq t (/= x)) x)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	735 )
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	736
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	737 ;; Type checking
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	738 (Check-Error wrong-type-argument (= 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	739 (Check-Error wrong-type-argument (<= 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	740 (Check-Error wrong-type-argument (>= 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	741 (Check-Error wrong-type-argument (< 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	742 (Check-Error wrong-type-argument (> 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	743 (Check-Error wrong-type-argument (/= 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	744
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	745 ;; Meat
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	746 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	747 (dolist (two '(2 2.0 ?\02))
2056 ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	748 (Assert (< one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	749 (Assert (<= one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	750 (Assert (<= two two) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	751 (Assert (> two one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	752 (Assert (>= two one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	753 (Assert (>= two two) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	754 (Assert (/= one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	755 (Assert (not (/= two two)) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	756 (Assert (not (< one one)) one)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	757 (Assert (not (> one one)) one)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	758 (Assert (<= one one two two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	759 (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	760 (Assert (>= two two one one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	761 (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	762 (Assert (= one one one) one)
2056 ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	763 (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	764 (Assert (not (/= one two one)) (list one two))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	765 ))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	766
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	767 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	768 (dolist (two '(2 2.0 ?\02))
2056 ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	769 (Assert (< one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	770 (Assert (<= one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	771 (Assert (<= two two) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	772 (Assert (> two one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	773 (Assert (>= two one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	774 (Assert (>= two two) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	775 (Assert (/= one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	776 (Assert (not (/= two two)) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	777 (Assert (not (< one one)) one)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	778 (Assert (not (> one one)) one)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	779 (Assert (<= one one two two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	780 (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	781 (Assert (>= two two one one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	782 (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	783 (Assert (= one one one) one)
2056 ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	784 (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	785 (Assert (not (/= one two one)) (list one two))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	786 ))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	787
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	788 ;; ad-hoc
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	789 (Assert (< 1 2))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	790 (Assert (< 1 2 3 4 5 6))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	791 (Assert (not (< 1 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	792 (Assert (not (< 2 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	793
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	794
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	795 (Assert (not (< 1 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	796 (Assert (< 1 2 3 4 5 6))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	797 (Assert (<= 1 2 3 4 5 6))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	798 (Assert (<= 1 2 3 4 5 6 6))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	799 (Assert (not (< 1 2 3 4 5 6 6)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	800 (Assert (<= 1 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	801
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	802 (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	803 (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	804 (Assert (= (point) (point-marker)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	805
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	806 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	807 (let ((big1 (1+ most-positive-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	808 (big2 (* 10 most-positive-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	809 (small1 (1- most-negative-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	810 (small2 (* 10 most-negative-fixnum)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	811 (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	812 big2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	813 (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	814 big2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	815 (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	816 small2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	817 (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	818 small2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	819 (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	820 big2))))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	821
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	822 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	823 (let ((big1 (div (* 10 most-positive-fixnum) 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	824 (big2 (div (* 5 most-positive-fixnum) 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	825 (big3 (div (* 7 most-positive-fixnum) 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	826 (small1 (div (* 10 most-negative-fixnum) 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	827 (small2 (div (* 5 most-negative-fixnum) 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	828 (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	829 (Assert (= big1 big2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	830 (Assert (= small1 small2))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	831 (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	832 big3))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	833 (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	834 big1 big2 big3))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	835 (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	836 small3))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	837 (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	838 small1 small2 small3))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	839 (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	840 small3))))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	841
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	842 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	843 ;; testing list-walker functions
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	844 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	845 (macrolet
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	846 ((test-fun
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	847 (fun)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	848 `(progn
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	849 (Check-Error wrong-number-of-arguments (,fun))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	850 (Check-Error wrong-number-of-arguments (,fun nil))
5346 b4ef3128160c Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq. Aidan Kehoe <kehoea@parhasard.net> parents: 5339 diff changeset	851 (Check-Error (malformed-list wrong-type-argument) (,fun nil 1))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	852 ,@(loop for n in '(1 2 2000)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	853 collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n))))))
5374 d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	854 (test-funs (&rest funs) `(progn ,@(loop for fun in funs collect `(test-fun ,fun))))
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	855 (test-old-funs (&rest funs)
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	856 `(when (and (fboundp 'old-eq) (subrp (symbol-function 'old-eq)))
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	857 ,@(loop for fun in funs collect `(test-fun ,fun)))))
5346 b4ef3128160c Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq. Aidan Kehoe <kehoea@parhasard.net> parents: 5339 diff changeset	858 (test-funs member* member memq
b4ef3128160c Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq. Aidan Kehoe <kehoea@parhasard.net> parents: 5339 diff changeset	859 assoc* assoc assq
b4ef3128160c Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq. Aidan Kehoe <kehoea@parhasard.net> parents: 5339 diff changeset	860 rassoc* rassoc rassq
b4ef3128160c Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq. Aidan Kehoe <kehoea@parhasard.net> parents: 5339 diff changeset	861 delete* delete delq
b4ef3128160c Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq. Aidan Kehoe <kehoea@parhasard.net> parents: 5339 diff changeset	862 remove* remove remq
5374 d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	863 remassoc remassq remrassoc remrassq)
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	864 (test-old-funs old-member old-memq old-assoc old-assq old-rassoc old-rassq
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	865 old-delete old-delq))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	866
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	867 (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	868 (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	869 (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	870 (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	871 (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	872 (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	873 (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	874 (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	875 (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	876 (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	877 (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	878 (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	879 (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	880 (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	881 (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	882 (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	883 (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	884 (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	885 (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	886 (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	887 (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	888 (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	889 (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	890 (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	891 (Assert (eq (rassq 6 x) nil)))
428 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 (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	894 (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	895 (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	896 (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	897 (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	898 (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	899 (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	900 (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	901 (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	902 (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	903 (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	904 (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	905 (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	906 (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	907 (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	908 (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	909 (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	910 (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	911 (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	912 (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	913 (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	914 (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	915 (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	916 (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	917 (Assert (eq (rassq "6" x) nil)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	918
5576 071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	919 (labels ((a () (list '(1 . 2) 3 '(4 . 5))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	920 (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	921 (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	922 (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	923 (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	924
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	925 (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	926 (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	927 (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	928 (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	929
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	930 (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	931 (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	932 (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	933 (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	934
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	935 (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	936 (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	937 (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	938 (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	939
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	940 (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	941 (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	942 (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	943 (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	944
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	945 (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	946 (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	947 (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	948 (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	949 (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	950 (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	951 (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	952 (Assert (let* ((x (a)) (y (delq '(1 . 2) x))) (and (eq x y) (equal y (a)))))
5374 d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	953 (when (and (fboundp 'old-eq) (subrp (symbol-function 'old-eq)))
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	954 (Assert (let* ((x (a)) (y (old-delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	955 (Assert (let* ((x (a)) (y (old-delq '(1 . 2) x))) (and (eq x y) (equal y (a)))))
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	956 (Assert (let* ((x (a)) (y (old-delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	957 (Assert (let* ((x (a)) (y (old-delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	958
5576 071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	959 (labels ((a () (list '("1" . "2") "3" '("4" . "5"))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	960 (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	961 (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	962 (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	963 (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	964
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	965 (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	966 (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	967 (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	968 (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	969
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	970 (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	971 (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	972 (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	973 (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	974
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	975 (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	976 (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	977 (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	978 (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	979
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	980 (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	981 (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	982 (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	983 (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	984
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	985 (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	986 (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	987 (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	988 (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	989
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 ;; function-max-args, function-min-args
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	992 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	993 (defmacro check-function-argcounts (fun min max)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	994 `(progn
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	995 (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	996 (Assert (eq (function-max-args ,fun) ,max))))
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 (check-function-argcounts 'prog1 1 nil) ; special form
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	999 (check-function-argcounts 'command-execute 1 3) ; normal subr
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1000 (check-function-argcounts 'funcall 1 nil) ; `MANY' subr
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1001 (check-function-argcounts 'garbage-collect 0 0) ; no args subr
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1002
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1003 ;; Test interpreted and compiled functions
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1004 (loop for (arglist min max) in
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1005 '(((arg1 arg2 &rest args) 2 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1006 ((arg1 arg2 &optional arg3 arg4) 2 4)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1007 ((arg1 arg2 &optional arg3 arg4 &rest args) 2 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1008 (() 0 0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1009 do
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1010 (eval
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1011 `(progn
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1012 (defun test-fun ,arglist nil)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1013 (check-function-argcounts '(lambda ,arglist nil) ,min ,max)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1014 (check-function-argcounts (byte-compile '(lambda ,arglist nil)) ,min ,max))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1015
4575 eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	1016 ;; Test subr-arity.
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	1017 (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	1018 '((let (1 . unevalled))
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	1019 (prog1 (1 . unevalled))
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	1020 (list (0 . many))
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	1021 (type-of (1 . 1))
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	1022 (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	1023 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	1024
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	1025 (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	1026 (lambda () (message "Hi there!"))))
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	1027
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	1028 (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	1029
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1030 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1031 ;; Detection of cyclic variable indirection loops
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1032 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1033 (fset 'test-sym1 'test-sym1)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1034 (Check-Error cyclic-function-indirection (test-sym1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1035
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1036 (fset 'test-sym1 'test-sym2)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1037 (fset 'test-sym2 'test-sym1)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1038 (Check-Error cyclic-function-indirection (test-sym1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1039 (fmakunbound 'test-sym1) ; else macroexpand-internal infloops!
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1040 (fmakunbound 'test-sym2)
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 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1043 ;; Test `type-of'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1044 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1045 (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	1046 (Assert (eq (type-of obarray) 'vector))
5595 391d809fa4e9 Update tests that have started failing because of changed design decisions. Aidan Kehoe <kehoea@parhasard.net> parents: 5576 diff changeset	1047 (Assert (eq (type-of 42) 'fixnum))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1048 (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	1049 (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	1050 (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	1051 (Assert (eq (type-of (selected-device)) 'device))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1052
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 ;; Test mapping functions
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1055 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1056 (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	1057 (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	1058 (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	1059 (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	1060 (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	1061 (Assert (equal (mapcar #'identity #*010) '(0 1 0)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1062
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1063 (let ((z 0) (list (make-list 1000 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1064 (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	1065 (Assert (eq 1000 z)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1066
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1067 (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	1068 (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	1069 (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	1070 (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	1071 (Assert (equal (mapvector #'identity #*010) [0 1 0]))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1072
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1073 (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	1074 (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	1075 (Assert (equal (mapconcat #'identity ["1" "2" "3"] "\|") "1\|2\|3"))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1076
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1077 ;; The following 2 functions used to crash XEmacs via mapcar1().
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1078 ;; 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	1079 (Assert
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1080 (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	1081 (mapcar
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1082 (lambda (y)
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1083 "Devious evil mapping function"
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1084 (when (eq (car y) 2) ; go out onto a limb
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1085 (setcdr x nil) ; cut it off behind us
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1086 (garbage-collect)) ; are we riding a magic broomstick?
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1087 (car y)) ; sorry, hard landing
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1088 x)))
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1089
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1090 (Assert
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1091 (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	1092 (mapcar
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1093 (lambda (y)
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1094 "Devious evil mapping function"
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1095 (when (eq (car y) 1)
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1096 (setcdr (cdr x) 42)) ; drop a brick wall onto the freeway
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1097 (car y))
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1098 x)))
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1099
5355 70b15ac66ee5 Correct a bug with circularity checking in #'mapcar, #'map, etc. Aidan Kehoe <kehoea@parhasard.net>* parents: 5353 diff changeset	1100 (Assert
70b15ac66ee5 Correct a bug with circularity checking in #'mapcar, #'map, etc. Aidan Kehoe <kehoea@parhasard.net>* parents: 5353 diff changeset	1101 (equal
70b15ac66ee5 Correct a bug with circularity checking in #'mapcar, #'map, etc. Aidan Kehoe <kehoea@parhasard.net>* parents: 5353 diff changeset	1102 (let ((list (list pi))) (mapcar* #'cons [1 2 3 4] (nconc list list)))
70b15ac66ee5 Correct a bug with circularity checking in #'mapcar, #'map, etc. Aidan Kehoe <kehoea@parhasard.net>* parents: 5353 diff changeset	1103 `((1 . ,pi) (2 . ,pi) (3 . ,pi) (4 . ,pi)))
70b15ac66ee5 Correct a bug with circularity checking in #'mapcar, #'map, etc. Aidan Kehoe <kehoea@parhasard.net>* parents: 5353 diff changeset	1104 "checking mapcar* behaves correctly when only one arg is circular")
70b15ac66ee5 Correct a bug with circularity checking in #'mapcar, #'map, etc. Aidan Kehoe <kehoea@parhasard.net>* parents: 5353 diff changeset	1105
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1106 (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	1107 (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	1108 (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	1109 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	1110 "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	1111
5299 28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar Aidan Kehoe <kehoea@parhasard.net> parents: 5295 diff changeset	1112 (let ((malformed-list '(1 2 3 4 hi there . tail)))
28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar Aidan Kehoe <kehoea@parhasard.net> parents: 5295 diff changeset	1113 (Check-Error malformed-list (mapcar #'identity malformed-list))
28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar Aidan Kehoe <kehoea@parhasard.net> parents: 5295 diff changeset	1114 (Check-Error malformed-list (map nil #'eq [1 2 3 4]
28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar Aidan Kehoe <kehoea@parhasard.net> parents: 5295 diff changeset	1115 malformed-list))
28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar Aidan Kehoe <kehoea@parhasard.net> parents: 5295 diff changeset	1116 (Check-Error malformed-list (list-length malformed-list)))
28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar Aidan Kehoe <kehoea@parhasard.net> parents: 5295 diff changeset	1117
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1118 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1119 ;; Test vector functions
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1120 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1121 (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	1122 (Assert (equal [] []))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1123 (Assert (not (equal [1 2 3] [])))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1124 (Assert (not (equal [1 2 3] [1 2 4])))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1125 (Assert (not (equal [0 2 3] [1 2 3])))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1126 (Assert (not (equal [1 2 3] [1 2 3 4])))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1127 (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	1128 (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	1129 (Assert (equal (make-vector 3 1) [1 1 1]))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1130
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1131 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1132 ;; Test bit-vector functions
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1133 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1134 (Assert (equal #010 #010))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1135 (Assert (equal #* #*))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1136 (Assert (not (equal #010 #011)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1137 (Assert (not (equal #010 #)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1138 (Assert (not (equal #110 #010)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1139 (Assert (not (equal #010 #0100)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1140 (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	1141 (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	1142 (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	1143 (Assert (equal (make-bit-vector 3 0) #*000))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1144
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1145 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1146 ;; Test buffer-local variables used as (ugh!) function parameters
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1147 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1148 (make-local-variable 'test-emacs-buffer-local-variable)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1149 (byte-compile
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1150 (defun test-emacs-buffer-local-parameter (test-emacs-buffer-local-variable)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1151 (setq test-emacs-buffer-local-variable nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1152 (test-emacs-buffer-local-parameter nil)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1153
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1154 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1155 ;; Test split-string
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1156 ;;-----------------------------------------------------
1425 74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent] stephent parents: 826 diff changeset	1157 ;; Keep nulls, explicit SEPARATORS
74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent] stephent parents: 826 diff changeset	1158 ;; 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	1159 ;; 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	1160 (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	1161 (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	1162 (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	1163 (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	1164 (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	1165 (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	1166 (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	1167 (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	1168 (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	1169 (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	1170 (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	1171 (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	1172 (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	1173 ;; Omit nulls, explicit SEPARATORS
74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent] stephent parents: 826 diff changeset	1174 (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	1175 (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	1176 (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	1177 (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	1178 (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	1179 (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	1180 (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	1181 (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	1182 (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	1183 (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	1184 (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	1185 (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	1186 (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	1187 ;; "Double-default" case
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1188 (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	1189 (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	1190 (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	1191 (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	1192 (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	1193 (Assert (equal (split-string "foobar") '("foobar")))
1425 74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent] stephent parents: 826 diff changeset	1194 ;; 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	1195 (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	1196 (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	1197 (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	1198 (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	1199 (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	1200 (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	1201 ;; 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	1202 (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	1203 '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1204 (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	1205 '("" "foo" "bar" "")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1206 (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	1207 '("" "foo" "bar" "")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1208 (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	1209 '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1210 (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	1211 '("foo" "bar" "")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1212 (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	1213 '("foobar")))
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1214
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1215 ;;-----------------------------------------------------
5035 b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1216 ;; 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	1217 ;;-----------------------------------------------------
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1218
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1219 (Assert
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1220 (equal
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1221 (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	1222 #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	1223 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	1224 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	1225 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	1226 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	1227 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	1228 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	1229 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	1230 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	1231 ?: ?\\)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1232 '("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	1233 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	1234 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	1235 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	1236 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	1237 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	1238 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	1239 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	1240 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	1241 (Assert
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1242 (equal
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1243 (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	1244 #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	1245 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	1246 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	1247 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	1248 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	1249 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	1250 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	1251 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	1252 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	1253 ?: ?\x00)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1254 '("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	1255 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	1256 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	1257 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	1258 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	1259 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	1260 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	1261 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	1262 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	1263 (Assert
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1264 (equal
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1265 (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	1266 #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	1267 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	1268 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	1269 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	1270 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	1271 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	1272 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	1273 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	1274 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	1275 '("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	1276 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	1277 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	1278 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	1279 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	1280 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	1281 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	1282 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	1283 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	1284
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1285 ;;-----------------------------------------------------
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1286 ;; Test near-text buffer functions.
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1287 ;;-----------------------------------------------------
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1288 (with-temp-buffer
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1289 (erase-buffer)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1290 (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	1291 (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	1292 (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	1293 (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	1294 (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	1295 (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	1296 (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	1297 (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	1298 (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	1299 (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	1300 (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	1301 (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	1302 (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	1303 (Assert (eq (following-char (current-buffer)) 0))
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1304 (insert "foobar")
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1305 (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	1306 (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	1307 (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	1308 (Assert (eq (following-char) 0))
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1309 (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	1310 (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	1311 (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	1312 (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	1313 (Assert (eq (following-char) ?f))
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1314 )
440 8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1315
8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1316 ;;-----------------------------------------------------
8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1317 ;; Test plist manipulation functions.
8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1318 ;;-----------------------------------------------------
8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1319 (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	1320 (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	1321 (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	1322 (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	1323 (Assert (eq t (plist-get nil t t)))
440 8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1324 (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	1325 (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	1326 (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	1327 (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	1328 (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	1329 (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	1330 (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	1331 (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	1332 (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	1333 (Assert (eq 5 (get sym 3 5)))
440 8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1334 )
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1335
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1336 (loop for obj in
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1337 (list (make-symbol "test-symbol")
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1338 "test-string"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1339 (make-extent nil nil nil)
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1340 (make-face 'test-face))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1341 do
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1342 (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	1343 (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	1344 (Assert (eq 4 (get obj ?3)) obj)
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1345 (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	1346 (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	1347 (Assert (eq t (remprop obj ?3)) obj)
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1348 (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	1349 (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	1350 (Assert (eq nil (remprop obj ?3)) obj)
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1351 (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	1352 (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	1353 (Assert (eq 5 (get obj ?3 5)) obj)
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1354 )
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1355
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1356 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1357 error "Object type has no properties"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1358 (get 2 'property))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1359
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1360 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1361 error "Object type has no settable properties"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1362 (put (current-buffer) 'property 'value))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1363
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1364 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1365 error "Object type has no removable properties"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1366 (remprop ?3 'property))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1367
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1368 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1369 error "Object type has no properties"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1370 (object-plist (symbol-function 'car)))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1371
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1372 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1373 error "Can't remove property from object"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1374 (remprop (make-extent nil nil nil) 'detachable))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1375
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1376 ;;-----------------------------------------------------
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1377 ;; Test subseq
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1378 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1379 (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	1380 (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	1381 (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	1382 (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	1383 (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	1384 (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	1385 (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	1386 (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	1387 (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	1388
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1389 (Check-Error wrong-type-argument (subseq 3 2))
1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1390 (Check-Error args-out-of-range (subseq [1 2 3] -42))
1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1391 (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	1392
5370 4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1393 (let ((string "hi there"))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1394 (Assert (equal (substring-no-properties "123" 0) "123"))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1395 (Assert (equal (substring-no-properties "1234" -3 -1) "23"))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1396 (Assert (equal (substring-no-properties "hi there" 0) "hi there"))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1397 (put-text-property 0 (length string) 'foo 'bar string)
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1398 (Assert (eq 'bar (get-text-property 0 'foo string)))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1399 (Assert (not
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1400 (get-text-property 0 'foo (substring-no-properties "hi there" 0))))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1401 (Check-Error wrong-type-argument (substring-no-properties nil 4))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1402 (Check-Error wrong-type-argument (substring-no-properties "hi there" pi))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1403 (Check-Error wrong-type-argument (substring-no-properties "hi there" 0.0)))
5360 46b53e84ea7a #'substring-no-properties: check STRING's type, get_string_range_char won't. Aidan Kehoe <kehoea@parhasard.net> parents: 5355 diff changeset	1404
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1405 ;;-----------------------------------------------------
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1406 ;; Time-related tests
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1407 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1408 (Assert (= (length (current-time-string)) 24))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1409
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1410 ;;-----------------------------------------------------
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1411 ;; format test
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1412 ;;-----------------------------------------------------
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1413 (Assert (string= (format "%d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1414 (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	1415 (Assert (string= (format "%b" 2) "10"))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1416 (Assert (string= (format "%x" 31) "1f"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1417 (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	1418 (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	1419 (Assert (string= (format "%b" 3) "11"))
826 6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1420 ;; 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	1421 ;; 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	1422 ;; is very hard.
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1423 (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	1424 (string= (format "%e" 100) "1.000000e+002")))
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1425 (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	1426 (string= (format "%E" 100) "1.000000E+002")))
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1427 (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	1428 (string= (format "%E" 100) "1.000000E+002")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1429 (Assert (string= (format "%f" 100) "100.000000"))
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1430 (Assert (string= (format "%7.3f" 12.12345) " 12.123"))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1431 (Assert (string= (format "%07.3f" 12.12345) "012.123"))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1432 (Assert (string= (format "%-7.3f" 12.12345) "12.123 "))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1433 (Assert (string= (format "%-07.3f" 12.12345) "12.123 "))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1434 (Assert (string= (format "%g" 100.0) "100"))
826 6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1435 (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	1436 (string= (format "%g" 0.000001) "1e-006")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1437 (Assert (string= (format "%g" 0.0001) "0.0001"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1438 (Assert (string= (format "%G" 100.0) "100"))
826 6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1439 (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	1440 (string= (format "%G" 0.000001) "1E-006")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1441 (Assert (string= (format "%G" 0.0001) "0.0001"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1442
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1443 (Assert (string= (format "%2$d%1$d" 10 20) "2010"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1444 (Assert (string= (format "%-d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1445 (Assert (string= (format "%-4d" 10) "10 "))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1446 (Assert (string= (format "%+d" 10) "+10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1447 (Assert (string= (format "%+d" -10) "-10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1448 (Assert (string= (format "%+4d" 10) " +10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1449 (Assert (string= (format "%+4d" -10) " -10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1450 (Assert (string= (format "% d" 10) " 10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1451 (Assert (string= (format "% d" -10) "-10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1452 (Assert (string= (format "% 4d" 10) " 10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1453 (Assert (string= (format "% 4d" -10) " -10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1454 (Assert (string= (format "%0d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1455 (Assert (string= (format "%0d" -10) "-10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1456 (Assert (string= (format "%04d" 10) "0010"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1457 (Assert (string= (format "%04d" -10) "-010"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1458 (Assert (string= (format "%*d" 4 10) " 10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1459 (Assert (string= (format "%*d" 4 -10) " -10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1460 (Assert (string= (format "%*d" -4 10) "10 "))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1461 (Assert (string= (format "%*d" -4 -10) "-10 "))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1462 (Assert (string= (format "%#d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1463 (Assert (string= (format "%#o" 8) "010"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1464 (Assert (string= (format "%#x" 16) "0x10"))
826 6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1465 (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	1466 (string= (format "%#e" 100) "1.000000e+002")))
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1467 (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	1468 (string= (format "%#E" 100) "1.000000E+002")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1469 (Assert (string= (format "%#f" 100) "100.000000"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1470 (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	1471 (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	1472 (string= (format "%#g" 0.000001) "1.00000e-006")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1473 (Assert (string= (format "%#g" 0.0001) "0.000100000"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1474 (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	1475 (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	1476 (string= (format "%#G" 0.000001) "1.00000E-006")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1477 (Assert (string= (format "%#G" 0.0001) "0.000100000"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1478 (Assert (string= (format "%.1d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1479 (Assert (string= (format "%.4d" 10) "0010"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1480 ;; Combination of `-', `+', ` ', `0', `#', `.', `*'
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1481 (Assert (string= (format "%-04d" 10) "10 "))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1482 (Assert (string= (format "%-*d" 4 10) "10 "))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1483 ;; #### Correctness of this behavior is questionable.
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1484 ;; It might be better to signal error.
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1485 (Assert (string= (format "%-*d" -4 10) "10 "))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1486 ;; These behavior is not specified.
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1487 ;; (format "%-+d" 10)
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1488 ;; (format "%- d" 10)
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1489 ;; (format "%-01d" 10)
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1490 ;; (format "%-#4x" 10)
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1491 ;; (format "%-.1d" 10)
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1492
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1493 (Assert (string= (format "%01.1d" 10) "10"))
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1494 (Assert (string= (format "%03.1d" 10) " 10"))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1495 (Assert (string= (format "%01.3d" 10) "010"))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1496 (Assert (string= (format "%1.3d" 10) "010"))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1497 (Assert (string= (format "%3.1d" 10) " 10"))
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1498
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1499 ;;; The following two tests used to use 1000 instead of 100,
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1500 ;;; 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	1501 (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	1502 (Assert (= 100 (length (format "%100f" 3.14))))
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1503
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1504 ;;; 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	1505 (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	1506 (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	1507 (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	1508 (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	1509 (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	1510 (Assert (= (read (format "%ld" most-negative-fixnum)) most-negative-fixnum))
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1511
4287 89e64783d068 [xemacs-hg @ 2007-11-27 13:51:03 by aidan] aidan parents: 2075 diff changeset	1512 ;; 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	1513 (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	1514 (Assert (eql (read (format "%.1000d" 1)) 1))
4287 89e64783d068 [xemacs-hg @ 2007-11-27 13:51:03 by aidan] aidan parents: 2075 diff changeset	1515
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1516 ;;; "%u" is undocumented, and Emacs Lisp has no unsigned type.
1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1517 ;;; 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	1518 ;;; 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	1519 ;;; 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	1520 ;;; to Emacs Lisp.
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	1521 ;;; 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	1522 (if (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	1523 (progn
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	1524 (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	1525 (Check-Error wrong-type-argument (format "%u" -1)))
5864 750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	1526 (Check-Error invalid-argument (read (format "%u" most-negative-fixnum)))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	1527 (Check-Error invalid-argument (read (format "%u" -1))))
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1528
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1529 ;; Check all-completions ignore element start with space.
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1530 (Assert (not (all-completions "" '((" hidden" . "object")))))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1531 (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	1532
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1533 (let* ((literal-with-uninterned
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1534 '(first-element
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1535 [#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	1536 #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	1537 #5=#:G32970 #6=#:G32972]))
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1538 (print-readably t)
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1539 (print-gensym t)
5560 58b38d5b32d0 Implement print-circle, allowing recursive and circular structures to be read. Aidan Kehoe <kehoea@parhasard.net> parents: 5553 diff changeset	1540 (print-continuous-numbering t)
4394 cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1541 (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	1542 (awkward-regexp "#1=#")
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1543 (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	1544 printed-with-uninterned)))
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1545 (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	1546 (1+ first-match-start)))))
4580 1d11ecca9cd0 Print char table values correctly. Aidan Kehoe <kehoea@parhasard.net> parents: 4575 diff changeset	1547
1d11ecca9cd0 Print char table values correctly. Aidan Kehoe <kehoea@parhasard.net> parents: 4575 diff changeset	1548 (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	1549 (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	1550 (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	1551 (prin1-to-string char-table-with-symbol)))
4580 1d11ecca9cd0 Print char table values correctly. Aidan Kehoe <kehoea@parhasard.net> parents: 4575 diff changeset	1552 "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	1553
4608 1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1554
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1555 (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	1556 (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	1557 nil ".el")))
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1558 (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	1559 (erase-buffer)
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1560 (insert
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1561 "\
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1562 ;; 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	1563 ;; Vload_file_name_internal of lread.c.
5911 48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1564 \(Check-Error setting-constant (aset #$ 0 ?\\ ))
4608 1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1565
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1566 ;; But modifying load-file-name should work:
5911 48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1567 \(let ((new-char ?\\ )
4608 1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1568 old-char)
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1569 (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	1570 (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	1571 (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	1572 (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	1573 (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	1574 \"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	1575
5911 48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1576 \(let* ((new-load-file-name \"hi there\")
4608 1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1577 (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	1578 (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	1579 \"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	1580
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1581 ")
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1582 (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	1583 (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	1584 (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	1585 (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	1586 (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	1587
5911 48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1588 ;; These used to crash with bignum support thanks to GMP:
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1589 (symbol-macrolet
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1590 ((positive-infinity
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1591 (expt (+ most-positive-fixnum 0.0) most-positive-fixnum))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1592 (negative-infinity
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1593 (expt (+ most-negative-fixnum 0.0) most-positive-fixnum))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1594 (not-a-number (expt -1 0.5)))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1595 (Check-Error range-error (ceiling positive-infinity))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1596 (Check-Error range-error (ceiling negative-infinity))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1597 (Check-Error range-error (ceiling positive-infinity 1))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1598 (Check-Error range-error (ceiling negative-infinity 1))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1599 (Check-Error range-error (floor positive-infinity))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1600 (Check-Error range-error (floor negative-infinity))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1601 (Check-Error range-error (floor positive-infinity 1))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1602 (Check-Error range-error (floor negative-infinity 1))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1603 (Check-Error range-error (round positive-infinity))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1604 (Check-Error range-error (round negative-infinity))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1605 (Check-Error range-error (round positive-infinity 1))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1606 (Check-Error range-error (round negative-infinity 1))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1607 (Check-Error range-error (ceiling not-a-number))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1608 (Check-Error range-error (ceiling not-a-number 1))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1609 (Check-Error range-error (floor not-a-number))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1610 (Check-Error range-error (floor not-a-number 1))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1611 (Check-Error range-error (round not-a-number))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1612 (Check-Error range-error (round not-a-number 1))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1613 (Check-Error range-error (coerce positive-infinity 'fixnum))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1614 (Check-Error range-error (coerce negative-infinity 'fixnum))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1615 (Check-Error range-error (coerce not-a-number 'fixnum))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1616 (Check-Error range-error (coerce positive-infinity 'integer))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1617 (Check-Error range-error (coerce negative-infinity 'integer))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1618 (Check-Error range-error (coerce not-a-number 'integer))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1619 (when (ignore-errors (coerce 1 'ratio))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1620 (Check-Error range-error (coerce positive-infinity 'ratio))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1621 (Check-Error range-error (coerce negative-infinity 'ratio))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1622 (Check-Error range-error (coerce not-a-number 'ratio)))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1623 (when (ignore-errors (coerce 1 'bigfloat))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1624 (Check-Error range-error (coerce positive-infinity 'bigfloat))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1625 (Check-Error range-error (coerce negative-infinity 'bigfloat))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1626 (Check-Error range-error (coerce not-a-number 'bigfloat))))
48386fd60fd0 GMP functions that take doubles choke on non-finite values, avoid that. Aidan Kehoe <kehoea@parhasard.net> parents: 5905 diff changeset	1627
5576 071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1628 (labels ((cl-floor (x &optional y)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1629 (let ((q (floor x y)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1630 (list q (- x (if y (* y q) q)))))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1631 (cl-ceiling (x &optional y)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1632 (let ((res (cl-floor x y)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1633 (if (= (car (cdr res)) 0) res
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1634 (list (1+ (car res)) (- (car (cdr res)) (or y 1))))))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1635 (cl-truncate (x &optional y)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1636 (if (eq (>= x 0) (or (null y) (>= y 0)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1637 (cl-floor x y) (cl-ceiling x y)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1638 (cl-round (x &optional y)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1639 (if y
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1640 (if (and (integerp x) (integerp y))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1641 (let* ((hy (/ y 2))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1642 (res (cl-floor (+ x hy) y)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1643 (if (and (= (car (cdr res)) 0)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1644 (= (+ hy hy) y)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1645 (/= (% (car res) 2) 0))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1646 (list (1- (car res)) hy)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1647 (list (car res) (- (car (cdr res)) hy))))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1648 (let ((q (round (/ x y))))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1649 (list q (- x (* q y)))))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1650 (if (integerp x) (list x 0)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1651 (let ((q (round x)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1652 (list q (- x q))))))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1653 (Assert-rounding (first second &key
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1654 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	1655 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	1656 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	1657 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	1658 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	1659 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	1660 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	1661 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	1662 (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	1663 (floor first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1664 (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	1665 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	1666 (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	1667 (floor first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1668 (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	1669 first one-floor-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1670 (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	1671 (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	1672 (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	1673 (floor first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1674 (format
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1675 "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	1676 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	1677 (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	1678 (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	1679 (format
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1680 "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	1681 first second))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1682 (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	1683 (ffloor first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1684 (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	1685 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	1686 (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	1687 (ffloor first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1688 (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	1689 first one-ffloor-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1690 (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	1691 (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	1692 (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	1693 (ffloor first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1694 (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	1695 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	1696 (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	1697 (ceiling first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1698 (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	1699 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	1700 (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	1701 (ceiling first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1702 (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	1703 first one-ceiling-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1704 (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	1705 (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	1706 (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	1707 (ceiling first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1708 (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	1709 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	1710 (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	1711 (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	1712 (format
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1713 "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	1714 first second))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1715 (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	1716 (fceiling first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1717 (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	1718 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	1719 (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	1720 (fceiling first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1721 (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	1722 first one-fceiling-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1723 (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	1724 (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	1725 (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	1726 (fceiling first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1727 (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	1728 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	1729 (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	1730 (round first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1731 (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	1732 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	1733 (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	1734 (round first 1)))
4686 cdabd56ce1b5 Fix various small issues with the multiple-value implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 4679 diff changeset	1735 (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	1736 first one-round-result))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1737 (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	1738 (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	1739 (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	1740 (round first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1741 (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	1742 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	1743 (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	1744 (fround first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1745 (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	1746 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	1747 (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	1748 (fround first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1749 (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	1750 first one-fround-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1751 (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	1752 (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	1753 (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	1754 (fround first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1755 (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	1756 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	1757 (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	1758 (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	1759 (format
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1760 "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	1761 first second))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1762 (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	1763 (truncate first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1764 (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	1765 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	1766 (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	1767 (truncate first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1768 (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	1769 first one-truncate-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1770 (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	1771 (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	1772 (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	1773 (truncate first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1774 (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	1775 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	1776 (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	1777 (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	1778 (format
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1779 "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	1780 first second))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1781 (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	1782 (ftruncate first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1783 (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	1784 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	1785 (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	1786 (ftruncate first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1787 (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	1788 first one-ftruncate-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1789 (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	1790 (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	1791 (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	1792 (ftruncate first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1793 (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	1794 first second two-ftruncate-result)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1795 (Assert-rounding-floating (pie ee)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1796 (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	1797 (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	1798 "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	1799 (Assert-rounding pie ee
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1800 :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	1801 :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	1802 :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	1803 :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	1804 :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	1805 :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	1806 :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	1807 :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	1808 :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	1809 :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	1810 :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	1811 :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	1812 :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	1813 :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	1814 :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	1815 :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	1816 (- pie (* 1.0 ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1817 (Assert-rounding pie (- ee)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1818 :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	1819 :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	1820 :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	1821 :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	1822 (- pie (* -2.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1823 :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	1824 :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	1825 :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	1826 :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	1827 (- pie (* -1.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1828 :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	1829 :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	1830 :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	1831 :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	1832 (- pie (* -1.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1833 :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	1834 :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	1835 :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	1836 :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	1837 (- pie (* -1.0 (- ee)))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1838 (Assert-rounding (- pie) ee
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1839 :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	1840 :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	1841 :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	1842 :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	1843 (- (- pie) (* -2.0 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1844 :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	1845 :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	1846 :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	1847 :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	1848 (- (- pie) (* -1.0 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1849 :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	1850 :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	1851 :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	1852 :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	1853 (- (- pie) (* -1.0 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1854 :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	1855 :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	1856 :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	1857 :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	1858 (- (- pie) (* -1.0 ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1859 (Assert-rounding (- pie) (- ee)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1860 :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	1861 :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	1862 :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	1863 :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	1864 (- (- pie) (* 1.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1865 :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	1866 :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	1867 :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	1868 :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	1869 (- (- pie) (* 2.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1870 :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	1871 :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	1872 :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	1873 :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	1874 (- (- pie) (* 1.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1875 :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	1876 :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	1877 :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	1878 :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	1879 (- (- pie) (* 1.0 (- ee)))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1880 (Assert-rounding ee pie
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1881 :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	1882 :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	1883 :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	1884 :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	1885 :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	1886 :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	1887 :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	1888 :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	1889 :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	1890 :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	1891 :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	1892 :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	1893 :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	1894 :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	1895 :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	1896 :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	1897 (Assert-rounding ee (- pie)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1898 :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	1899 :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	1900 :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	1901 :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	1902 (- ee (* -1.0 (- pie))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1903 :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	1904 :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	1905 :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	1906 :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	1907 :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	1908 :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	1909 :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	1910 :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	1911 (- ee (* -1.0 (- pie))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1912 :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	1913 :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	1914 :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	1915 :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	1916 ;; First, two integers:
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1917 (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	1918 :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	1919 :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	1920 :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	1921 :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	1922 :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	1923 :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	1924 :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	1925 (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	1926 :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	1927 :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	1928 :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	1929 :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	1930 :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	1931 :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	1932 :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	1933 (Assert-rounding -27 8
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1934 :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	1935 :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	1936 :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	1937 :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	1938 :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	1939 :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	1940 :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	1941 :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	1942 (Assert-rounding -27 -8
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1943 :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	1944 :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	1945 :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	1946 :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	1947 :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	1948 :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	1949 :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	1950 :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	1951 (Assert-rounding 8 27
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1952 :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	1953 :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	1954 :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	1955 :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	1956 :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	1957 :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	1958 :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	1959 :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	1960 (Assert-rounding 8 -27
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1961 :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	1962 :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	1963 :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	1964 :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	1965 :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	1966 :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	1967 :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	1968 :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	1969 (Assert-rounding -8 27
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1970 :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	1971 :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	1972 :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	1973 :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	1974 :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	1975 :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	1976 :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	1977 :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	1978 (Assert-rounding -8 -27
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1979 :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	1980 :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	1981 :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	1982 :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	1983 :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	1984 :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	1985 :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	1986 :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	1987 (Assert-rounding 32 4
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1988 :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	1989 :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	1990 :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	1991 :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	1992 :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	1993 :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	1994 :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	1995 :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	1996 (Assert-rounding 32 -4
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1997 :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	1998 :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	1999 :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	2000 :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	2001 :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	2002 :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	2003 :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	2004 :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	2005 (Assert-rounding 12 9
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2006 :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	2007 :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	2008 :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	2009 :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	2010 :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	2011 :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	2012 :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	2013 :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	2014 (Assert-rounding 10 4
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2015 :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	2016 :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	2017 :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	2018 :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	2019 :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	2020 :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	2021 :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	2022 :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	2023 (Assert-rounding 14 4
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2024 :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	2025 :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	2026 :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	2027 :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	2028 :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	2029 :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	2030 :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	2031 :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	2032 ;; Now, two floats:
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2033 (Assert-rounding-floating pi e)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2034 (when (featurep 'bigfloat)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2035 (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	2036 (when (featurep 'bignum)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2037 (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	2038 "In the unlikely event that most-positive-fixnum is even, rewrite this.")
5912 47ffa085a9ad Fix a bug when passing a float to truncate and giving a bignum result. Aidan Kehoe <kehoea@parhasard.net> parents: 5911 diff changeset	2039 (Assert (equal (multiple-value-list (truncate (+ most-positive-fixnum 2.0)))
47ffa085a9ad Fix a bug when passing a float to truncate and giving a bignum result. Aidan Kehoe <kehoea@parhasard.net> parents: 5911 diff changeset	2040 (list (+ most-positive-fixnum 2) 0.0))
47ffa085a9ad Fix a bug when passing a float to truncate and giving a bignum result. Aidan Kehoe <kehoea@parhasard.net> parents: 5911 diff changeset	2041 "checking a bug in single-argument truncate's remainder fixed")
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2042 (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	2043 :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	2044 :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	2045 :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	2046 :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	2047 :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	2048 :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	2049 :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	2050 :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	2051 :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	2052 :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	2053 :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	2054 :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	2055 :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	2056 :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	2057 :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	2058 :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	2059 (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	2060 :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	2061 :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	2062 :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	2063 :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	2064 :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	2065 :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	2066 :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	2067 :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	2068 :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	2069 :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	2070 :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	2071 :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	2072 :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	2073 :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	2074 :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	2075 :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	2076 (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	2077 :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	2078 :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	2079 :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	2080 :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	2081 :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	2082 :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	2083 :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	2084 :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	2085 :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	2086 :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	2087 :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	2088 :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	2089 :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	2090 :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	2091 :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	2092 :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	2093 ;; 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	2094 (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	2095 :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	2096 :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	2097 :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	2098 ;; 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	2099 ;; 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	2100 ;; 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	2101 ;; 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	2102 ;; 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	2103 :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	2104 :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	2105 :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	2106 :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	2107 :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	2108 :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	2109 :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	2110 :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	2111 :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	2112 :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	2113 :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	2114 :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	2115 ;; 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	2116 :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	2117 (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	2118 :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	2119 :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	2120 :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	2121 ;; 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	2122 :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	2123 :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	2124 :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	2125 :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	2126 :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	2127 :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	2128 :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	2129 :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	2130 :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	2131 :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	2132 :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	2133 :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	2134 ;; See commentary above
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2135 :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	2136 1)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2137 (when (featurep 'ratio)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2138 (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	2139 :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	2140 :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	2141 :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	2142 :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	2143 :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	2144 :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	2145 :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	2146 :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	2147 (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	2148 :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	2149 :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	2150 :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	2151 :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	2152 :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	2153 :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	2154 :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	2155 :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	2156
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2157 ;; 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	2158 ;; 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	2159 ;; 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	2160 ;; output here.
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2161
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2162 (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	2163 (let ((print-readably t))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2164 (princ first)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2165 (princ " ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2166 (princ second)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2167 (princ " :one-floor-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2168 (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	2169 (princ " :two-floor-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2170 (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	2171 (princ " :one-ffloor-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2172 (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	2173 (princ " :two-ffloor-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2174 (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	2175 (princ " :one-ceiling-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2176 (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	2177 (princ " :two-ceiling-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2178 (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	2179 (princ " :one-fceiling-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2180 (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	2181 (princ " :two-fceiling-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2182 (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	2183 (princ " :one-round-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2184 (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	2185 (princ " :two-round-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2186 (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	2187 (princ " :one-fround-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2188 (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	2189 (princ " :two-fround-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2190 (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	2191 (princ " :one-truncate-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2192 (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	2193 (princ " :two-truncate-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2194 (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	2195 (princ " :one-ftruncate-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2196 (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	2197 (princ " :two-ftruncate-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2198 (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	2199
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2200 ;; Multiple value tests.
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2201
5576 071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2202 (labels ((foo (x y)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2203 (floor (+ x y) y))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2204 (foo-zero (x y)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2205 (values (floor (+ x y) y)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2206 (multiple-value-function-returning-t ()
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2207 (values t pi e degrees-to-radians radians-to-degrees))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2208 (multiple-value-function-returning-nil ()
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2209 (values nil pi e radians-to-degrees degrees-to-radians))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2210 (function-throwing-multiple-values ()
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2211 (let* ((listing '(0 3 4 nil "string" symbol))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2212 (tail listing)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2213 elt)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2214 (while t
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2215 (setq tail (cdr listing)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2216 elt (car listing)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2217 listing tail)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2218 (when (null elt)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2219 (throw 'VoN61Lo4Y (multiple-value-function-returning-t)))))))
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2220 (Assert
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2221 (= (+ (floor 5 3) (floor 19 4)) (+ 1 4) 5)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2222 "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	2223 (Assert
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2224 (= 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	2225 "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	2226 (Assert
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2227 (= 1 (length (multiple-value-list
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2228 (foo-zero 400 (1+ most-positive-fixnum)))))
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2229 "Checking multiple values are discarded correctly when forced")
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2230 (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	2231 (Assert (equal '(-1 1)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2232 (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	2233 "Checking #'multiple-value-list gives a sane result")
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2234 (let ((ey 40000)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2235 (bee "this is a string")
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2236 (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	2237 (Assert (equal
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2238 (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	2239 (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	2240 "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	2241 (Assert (equal
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2242 (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	2243 (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	2244 "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	2245 (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	2246 "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	2247 (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	2248 "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	2249 (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	2250 "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	2251 (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	2252 (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	2253 "Checking #'multiple-value-prog1 passes back multiple values")
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2254 (multiple-value-bind (floored remainder this-is-nil)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2255 (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	2256 (Assert (= floored 3)
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2257 "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	2258 (Assert (eql remainder (- pi 3.0))
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2259 "Checking remainder bound correctly")
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2260 (Assert (null this-is-nil)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2261 "Checking trailing arg bound but nil"))
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2262 (let ((ey 40000)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2263 (bee "this is a string")
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2264 (cee #s(hash-table size 256 data (969 ?\xF9))))
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2265 (multiple-value-setq (ey bee cee)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2266 (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	2267 (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	2268 (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	2269 (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	2270 (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	2271 "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	2272 (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	2273 "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	2274 (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	2275 "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	2276 (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	2277 (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	2278 "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	2279 (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	2280 (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	2281 "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	2282 (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	2283 (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	2284 "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	2285 (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	2286 (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	2287 "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	2288 (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	2289 (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	2290 "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	2291 (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	2292 (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	2293 "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	2294 (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	2295 (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2296 (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	2297 "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	2298 (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	2299 (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	2300 "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	2301 (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	2302 (multiple-value-prog1
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2303 (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	2304 "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	2305 (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	2306 (multiple-value-list
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2307 (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	2308 (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	2309 (multiple-value-list
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2310 (loop
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2311 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	2312 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	2313 (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	2314 "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	2315 (Assert
cdabd56ce1b5 Fix various small issues with the multiple-value implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 4679 diff changeset	2316 (null (or))
cdabd56ce1b5 Fix various small issues with the multiple-value implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 4679 diff changeset	2317 "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	2318 (Assert (eq t (and))
4686 cdabd56ce1b5 Fix various small issues with the multiple-value implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 4679 diff changeset	2319 "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	2320 (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	2321 (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	2322 (* 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	2323 "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	2324
4792 95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2325 ;; #'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	2326 (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	2327 (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	2328 (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	2329 (+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	2330 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	2331 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	2332 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	2333 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	2334 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	2335
5188 000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2336 (macrolet
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2337 ((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	2338 (let (res)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2339 (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	2340 (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	2341 (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	2342 (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	2343 (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	2344 ,(quote-maybe y))) res)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2345 (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	2346 ,(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	2347 (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	2348 (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	2349 res))))
5188 000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2350 (cons 'progn (nreverse res))))
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2351 (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	2352 (let (res)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2353 (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	2354 (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	2355 (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	2356 (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	2357 ,(quote-maybe y)))) res)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2358 (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	2359 ,(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	2360 (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	2361 (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	2362 `(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	2363 (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	2364 ,@(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	2365 (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	2366 (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	2367 (equalp-equal-list-tests
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2368 `(,@(when (featurep 'bignum)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2369 (read "((111111111111111111111111111111111111111111111111111
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2370 111111111111111111111111111111111111111111111111111.0))"))
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2371 (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	2372 (21845 #b101010101010101 #x5555)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2373 (1.5 1.500000000000000000000000000000000000000000000000000000000
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2374 ,@(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	2375 ;; 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	2376 ;;(-12345678901234567890123457890123457890123457890123457890123457890
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2377 ;; -12345678901234567890123457890123457890123457890123457890123457890.0)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2378 (-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	2379 (equalp-diff-list-tests
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2380 `(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	2381 ,@(when (featurep 'bignum)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2382 (read "(5555555555555555555555555555555555555
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2383 -5555555555555555555555555555555555555)"))
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2384 -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	2385 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	2386 ,@(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	2387 55555555555555555555555555555555555555555/2718281828459045
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2388 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	2389 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	2390
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	2391 (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	2392 "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	2393 (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	2394 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	2395 "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	2396 (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	2397 "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	2398 ;; 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	2399 (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	2400 "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	2401 (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	2402 "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	2403 "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	2404 (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	2405 "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	2406 "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	2407 (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	2408 "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	2409 (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	2410 "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	2411 (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	2412 "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	2413 (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	2414 (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	2415 "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	2416 (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	2417 "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	2418 (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	2419 (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	2420 (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	2421 "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	2422 (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	2423 [?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	2424 (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	2425 "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	2426 (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	2427 (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	2428 "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	2429 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	2430 (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	2431 (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	2432 "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	2433 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	2434 (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	2435 (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	2436 "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	2437 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	2438 (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	2439 "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	2440 (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	2441 "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	2442 (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	2443 "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	2444 (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	2445 "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	2446 (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	2447 (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	2448 (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	2449 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	2450 "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	2451 (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	2452 (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	2453 (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	2454 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	2455 "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	2456 (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	2457 (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	2458 (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	2459 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	2460 "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	2461
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2462 ;; 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	2463 ;;
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2464 ;; 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	2465 ;;
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2466 ;; 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	2467 ;; 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	2468 ;; 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	2469 ;; 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	2470 ;; 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	2471 ;; 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	2472
4795 084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2473 (loop
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2474 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	2475 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	2476 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	2477 do
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2478 (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	2479 (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	2480 (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	2481 (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	2482 (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	2483 (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	2484 (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	2485 (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	2486
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2487 (loop
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2488 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	2489 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	2490 (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	2491
4885 6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2492 ;; #'member, #'assoc tests.
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2493
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2494 (when (featurep 'bignum)
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2495 (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	2496 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	2497 (assoc*-list (loop
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2498 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	2499 collect (cons elt (random))))
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2500 (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	2501 hashed-bignum)
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2502 (macrolet
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2503 ((1+most-positive-fixnum ()
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2504 (1+ most-positive-fixnum))
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2505 (1-most-negative-fixnum ()
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2506 (1- most-negative-fixnum))
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2507 (*-2-most-positive-fixnum ()
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2508 (* 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	2509 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2510 (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	2511 (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	2512 "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	2513 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2514 (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	2515 (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	2516 "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	2517 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2518 (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	2519 (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	2520 "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	2521 (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	2522 "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	2523 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2524 (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	2525 (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	2526 "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	2527 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2528 (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	2529 (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	2530 "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	2531 (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	2532 (gensym) hashing)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2533 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2534 (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	2535 (gethash hashed-bignum hashing))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2536 "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	2537
5700 37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2538 ;; #'subsetp tests.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2539 ;; Return non-nil if every element of LIST1 also appears in LIST2.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2540 ;; A couple of non-nondegenerate false cases.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2541 (Assert (not (subsetp (list ?a ?b) (list ?c ?d))))
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2542 (Assert (not (subsetp (list ?a ?b) (list ?b ?c ?d))))
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2543 ;; Next five thanks to Steven and Benson Mitchell on XEmacs Beta
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2544 ;; <50D16FF7.4090708@bnin.net>.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2545 ;; Two non-degenerate true cases.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2546 (Assert (subsetp (list ?a) (list ?a ?b ?c ?d)))
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2547 (Assert (subsetp (list ?a ?b) (list ?a ?b ?c ?d)))
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2548 ;; The three degenerate cases involving nil.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2549 (Assert (not (subsetp (list ?a) nil)))
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2550 (Assert (subsetp nil (list ?a ?b ?c ?d)))
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2551 (Assert (subsetp nil nil))
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2552 ;; #### We should also test the keywords.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2553 ;; #### We should also test the error conditions.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2554
5241 d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2555 ;;
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2556 (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	2557 (Check-Error
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2558 invalid-state
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2559 (let ((str "aaaaaaaaaaaaa")
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2560 (called 0)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2561 modified)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2562 (reduce #'+ str
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2563 :key #'(lambda (object)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2564 (prog1
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2565 object
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2566 (incf called)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2567 (or modified
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2568 (and (> called 5)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2569 (setq modified
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2570 (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	2571
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2572 (Assert
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2573 (eql 55
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2574 (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	2575 (called 0)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2576 modified)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2577 (reduce #'+
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2578 sequence
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2579 :key
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2580 #'(lambda (object) (prog1
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2581 object
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2582 (incf called)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2583 (and (eql called 5)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2584 (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	2585 (garbage-collect))))))
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2586 "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	2587
5244 04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2588 (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	2589 `(((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	2590 ((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	2591 "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	2592
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2593 (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	2594 `(((mswindows) . [nothing])
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2595 ((tty) . [string :data " "]))
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2596 'image t)))
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2597 "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	2598
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2599 (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	2600 (canonicalize-inst-list
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2601 `(((,(gensym)) . [nothing])
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2602 ((tty) . [string :data " "]))
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2603 'image))
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2604
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2605 (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	2606 (canonicalize-inst-list
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2607 `(((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	2608 ((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	2609
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2610 ;; 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	2611 ;; 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	2612 ;; 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	2613 ;; 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	2614 ;; 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	2615 ;; 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	2616
5243 808131ba4a57 Print symbols with ratio-like names and the associated ratios distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5241 diff changeset	2617 (when (featurep 'ratio)
808131ba4a57 Print symbols with ratio-like names and the associated ratios distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5241 diff changeset	2618 (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	2619 "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	2620 (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	2621 "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	2622
5283 be436ac36ba4 Don't share a counter when checking for circularity, list_merge(). Aidan Kehoe <kehoea@parhasard.net> parents: 5244 diff changeset	2623 (let* ((count 0)
be436ac36ba4 Don't share a counter when checking for circularity, list_merge(). Aidan Kehoe <kehoea@parhasard.net> parents: 5244 diff changeset	2624 (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	2625 (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	2626 (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	2627 "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	2628
5576 071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2629 (labels ((list-nreverse (list)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2630 (do ((list1 list (cdr list1))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2631 (list2 nil (prog1 list1 (setcdr list1 list2))))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2632 ((atom list1) list2))))
5300 9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2633 (let* ((integers (loop for i from 0 to 6000 collect i))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2634 (characters (mapcan #'(lambda (integer)
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2635 (if (char-int-p integer)
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2636 (list (int-char integer)))) integers))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2637 (fourth-bit #'(lambda (integer) (ash (logand #x10 integer) -4)))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2638 (bits (mapcar fourth-bit integers))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2639 (vector (vconcat integers))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2640 (string (concat characters))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2641 (bit-vector (bvconcat bits)))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2642 (Assert (equal (reverse vector)
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2643 (vconcat (list-nreverse (copy-list integers)))))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2644 (Assert (eq vector (nreverse vector)))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2645 (Assert (equal vector (vconcat (list-nreverse (copy-list integers)))))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2646 (Assert (equal (reverse string)
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2647 (concat (list-nreverse (copy-list characters)))))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2648 (Assert (eq string (nreverse string)))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2649 (Assert (equal string (concat (list-nreverse (copy-list characters)))))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2650 (Assert (eq bit-vector (nreverse bit-vector)))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2651 (Assert (equal (bvconcat (list-nreverse (copy-list bits))) bit-vector))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2652 (Assert (not (equal bit-vector
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2653 (mapcar fourth-bit
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2654 (loop for i from 0 to 6000 collect i)))))))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2655
5307 c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2656 (Check-Error wrong-type-argument (self-insert-command 'self-insert-command))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2657 (Check-Error wrong-type-argument (make-list 'make-list 'make-list))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2658 (Check-Error wrong-type-argument (make-vector 'make-vector 'make-vector))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2659 (Check-Error wrong-type-argument (make-bit-vector 'make-bit-vector
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2660 'make-bit-vector))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2661 (Check-Error wrong-type-argument (make-byte-code '(&rest ignore) "\xc0\x87" [4]
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2662 'ignore))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2663 (Check-Error wrong-type-argument (make-string ?a ?a))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2664 (Check-Error wrong-type-argument (nth-value 'nth-value (truncate pi e)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2665 (Check-Error wrong-type-argument (make-hash-table :test #'eql :size :size))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2666 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2667 (accept-process-output nil 'accept-process-output))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2668 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2669 (accept-process-output nil 2000 'accept-process-output))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2670 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2671 (self-insert-command 'self-insert-command))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2672 (Check-Error wrong-type-argument (string-to-number "16" 'string-to-number))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2673 (Check-Error wrong-type-argument (move-to-column 'move-to-column))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2674 (stop-profiling)
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2675 (Check-Error wrong-type-argument (start-profiling (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2676 (stop-profiling)
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2677 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2678 (fill '(1 2 3 4 5) 1 :start (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2679 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2680 (fill [1 2 3 4 5] 1 :start (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2681 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2682 (fill "1 2 3 4 5" ?1 :start (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2683 (Check-Error wrong-type-argument
5323 f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2684 (fill #*10101010 1 :start (float most-positive-fixnum)))
5307 c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2685 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2686 (fill '(1 2 3 4 5) 1 :end (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2687 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2688 (fill [1 2 3 4 5] 1 :end (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2689 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2690 (fill "1 2 3 4 5" ?1 :end (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2691 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2692 (fill #*10101010 1 :end (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2693 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2694 (reduce #'cons '(1 2 3 4 5) :start (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2695 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2696 (reduce #'cons [1 2 3 4 5] :start (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2697 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2698 (reduce #'cons "1 2 3 4 5" :start (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2699 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2700 (reduce #'cons #*10101010 :start (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2701 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2702 (reduce #'cons '(1 2 3 4 5) :end (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2703 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2704 (reduce #'cons [1 2 3 4 5] :end (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2705 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2706 (reduce #'cons "1 2 3 4 5" :end (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2707 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2708 (reduce #'cons #*10101010 :end (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2709
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2710 (when (featurep 'bignum)
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2711 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2712 (self-insert-command (* 2 most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2713 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2714 (make-list (* 3 most-positive-fixnum) 'make-list))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2715 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2716 (make-vector (* 4 most-positive-fixnum) 'make-vector))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2717 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2718 (make-bit-vector (+ 2 most-positive-fixnum) 'make-bit-vector))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2719 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2720 (make-byte-code '(&rest ignore) "\xc0\x87" [4]
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2721 (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2722 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2723 (make-byte-code '(&rest ignore) "\xc0\x87" [4]
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2724 #x10000))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2725 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2726 (make-string (* 4 most-positive-fixnum) ?a))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2727 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2728 (nth-value most-positive-fixnum (truncate pi e)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2729 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2730 (make-hash-table :test #'equalp :size (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2731 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2732 (accept-process-output nil 4294967))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2733 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2734 (accept-process-output nil 10 (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2735 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2736 (self-insert-command (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2737 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2738 (string-to-number "16" (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2739 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2740 (recent-keys (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2741 (when (featurep 'xbm)
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2742 (Check-Error-Message
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2743 invalid-argument
5736 3192994c49ca Convert C (un)signed long long values to bignums properly. Jerry James <james@xemacs.org> parents: 5700 diff changeset	2744 "^Height must be a natural number"
5307 c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2745 (set-face-background-pixmap
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2746 'left-margin
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2747 `[xbm :data (20 ,(* 2 most-positive-fixnum) "random-text")])))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2748 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2749 (move-to-column (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2750 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2751 (move-to-column (1- most-negative-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2752 (stop-profiling)
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2753 (when (< most-positive-fixnum (lsh 1 32))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2754 ;; We only support machines with integers of 32 bits or more. If
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2755 ;; most-positive-fixnum is less than 2^32, we're on a 32-bit machine,
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2756 ;; and it's appropriate to test start-profiling with a bignum.
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2757 (Assert (eq nil (start-profiling (* most-positive-fixnum 2)))))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2758 (stop-profiling)
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2759 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2760 (fill '(1 2 3 4 5) 1 :start (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2761 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2762 (fill [1 2 3 4 5] 1 :start (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2763 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2764 (fill "1 2 3 4 5" ?1 :start (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2765 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2766 (fill #*10101010 1 :start (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2767 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2768 (fill '(1 2 3 4 5) 1 :end (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2769 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2770 (fill [1 2 3 4 5] 1 :end (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2771 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2772 (fill "1 2 3 4 5" ?1 :end (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2773 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2774 (fill #*10101010 1 :end (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2775 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2776 (reduce #'cons '(1 2 3 4 5) :start (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2777 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2778 (reduce #'cons [1 2 3 4 5] :start (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2779 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2780 (reduce #'cons "1 2 3 4 5" :start (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2781 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2782 (reduce #'cons #*10101010 :start (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2783 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2784 (reduce #'cons '(1 2 3 4 5) :end (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2785 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2786 (reduce #'cons [1 2 3 4 5] :end (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2787 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2788 (reduce #'cons "1 2 3 4 5" :end (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2789 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2790 (reduce #'cons #*10101010 :end (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2791 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2792 (replace '(1 2 3 4 5) [5 4 3 2 1]
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2793 :start1 (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2794 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2795 (replace '(1 2 3 4 5) [5 4 3 2 1]
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2796 :start2 (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2797 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2798 (replace '(1 2 3 4 5) [5 4 3 2 1]
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2799 :end1 (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2800 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2801 (replace '(1 2 3 4 5) [5 4 3 2 1]
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2802 :end2 (1+ most-positive-fixnum))))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2803
5323 f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2804 (symbol-macrolet
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2805 ((list-length 2048) (vector-length 512) (string-length (* 8192 2)))
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2806 (let ((list
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2807 ;; CIRCULAR_LIST_SUSPICION_LENGTH is 1024, it's helpful if this list
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2808 ;; is longer than that.
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2809 (make-list list-length 'make-list))
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2810 (vector (make-vector vector-length 'make-vector))
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2811 (bit-vector (make-bit-vector vector-length 1))
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2812 (string (make-string string-length
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2813 (or (decode-char 'ucs #x20ac) ?\xFF)))
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2814 (item 'cons))
5347 fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2815 (macrolet
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2816 ((construct-item-sequence-checks (&rest functions)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2817 (cons
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2818 'progn
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2819 (mapcan
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2820 #'(lambda (function)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2821 `((Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2822 (,function item list
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2823 :start (1+ list-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2824 :end (1+ list-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2825 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2826 (,function item list :start -1
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2827 :end list-length))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2828 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2829 (,function item list :end (* 2 list-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2830 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2831 (,function item vector
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2832 :start (1+ vector-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2833 :end (1+ vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2834 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2835 (,function item vector :start -1))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2836 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2837 (,function item vector
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2838 :end (* 2 vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2839 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2840 (,function item bit-vector
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2841 :start (1+ vector-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2842 :end (1+ vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2843 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2844 (,function item bit-vector :start -1))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2845 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2846 (,function item bit-vector
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2847 :end (* 2 vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2848 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2849 (,function item string
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2850 :start (1+ string-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2851 :end (1+ string-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2852 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2853 (,function item string :start -1))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2854 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2855 (,function item string
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2856 :end (* 2 string-length)))))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2857 functions)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2858 (construct-one-sequence-checks (&rest functions)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2859 (cons
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2860 'progn
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2861 (mapcan
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2862 #'(lambda (function)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2863 `((Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2864 (,function (copy-sequence list)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2865 :start (1+ list-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2866 :end (1+ list-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2867 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2868 (,function (copy-sequence list)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2869 :start -1 :end list-length))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2870 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2871 (,function (copy-sequence list)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2872 :end (* 2 list-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2873 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2874 (,function (copy-sequence vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2875 :start (1+ vector-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2876 :end (1+ vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2877 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2878 (,function (copy-sequence vector) :start -1))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2879 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2880 (,function (copy-sequence vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2881 :end (* 2 vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2882 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2883 (,function (copy-sequence bit-vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2884 :start (1+ vector-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2885 :end (1+ vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2886 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2887 (,function (copy-sequence bit-vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2888 :start -1))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2889 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2890 (,function (copy-sequence bit-vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2891 :end (* 2 vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2892 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2893 (,function (copy-sequence string)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2894 :start (1+ string-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2895 :end (1+ string-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2896 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2897 (,function (copy-sequence string) :start -1))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2898 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2899 (,function (copy-sequence string)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2900 :end (* 2 string-length)))))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2901 functions)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2902 (construct-two-sequence-checks (&rest functions)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2903 (cons
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2904 'progn
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2905 (mapcan
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2906 #'(lambda (function)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2907 `((Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2908 (,function (copy-sequence list)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2909 (copy-sequence list)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2910 :start1 (1+ list-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2911 :end1 (1+ list-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2912 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2913 (,function (copy-sequence list)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2914 (copy-sequence list)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2915 :start1 -1 :end1 list-length))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2916 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2917 (,function (copy-sequence list)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2918 (copy-sequence list)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2919 :end1 (* 2 list-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2920 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2921 (,function (copy-sequence vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2922 (copy-sequence vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2923 :start1 (1+ vector-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2924 :end1 (1+ vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2925 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2926 (,function
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2927 (copy-sequence vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2928 (copy-sequence vector) :start1 -1))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2929 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2930 (,function (copy-sequence vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2931 (copy-sequence vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2932 :end1 (* 2 vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2933 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2934 (,function (copy-sequence bit-vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2935 (copy-sequence bit-vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2936 :start1 (1+ vector-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2937 :end1 (1+ vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2938 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2939 (,function (copy-sequence bit-vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2940 (copy-sequence bit-vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2941 :start1 -1))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2942 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2943 (,function (copy-sequence bit-vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2944 (copy-sequence bit-vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2945 :end1 (* 2 vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2946 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2947 (,function (copy-sequence string)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2948 (copy-sequence string)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2949 :start1 (1+ string-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2950 :end1 (1+ string-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2951 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2952 (,function (copy-sequence string)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2953 (copy-sequence string) :start1 -1))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2954 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2955 (,function (copy-sequence string)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2956 (copy-sequence string)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2957 :end1 (* 2 string-length)))))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2958 functions))))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2959 (construct-item-sequence-checks count position find delete* remove*
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2960 reduce)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2961 (construct-one-sequence-checks delete-duplicates remove-duplicates)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2962 (construct-two-sequence-checks replace mismatch search))))
5323 f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2963
5336 287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2964 (let* ((list (list 1 2 3 4 5 6 7 120 'hi-there '#:everyone))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2965 (vector (map 'vector #'identity list))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2966 (bit-vector (map 'bit-vector
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2967 #'(lambda (object) (if (fixnump object) 1 0)) list))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2968 (string (map 'string
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2969 #'(lambda (object) (or (and (fixnump object)
5772 cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	2970 (int-char object))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	2971 (decode-char 'ucs #x20ac)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	2972 ?\x20))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	2973 list))
5336 287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2974 (gensym (gensym)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2975 (Assert (null (find 'not-in-it list)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2976 (Assert (null (find 'not-in-it vector)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2977 (Assert (null (find 'not-in-it bit-vector)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2978 (Assert (null (find 'not-in-it string)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2979 (loop
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2980 for elt being each element in vector using (index position)
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2981 do
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2982 (Assert (eq elt (find elt list)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2983 (Assert (eq (elt list position) (find elt vector))))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2984 (Assert (eq gensym (find 'not-in-it list :default gensym)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2985 (Assert (eq gensym (find 'not-in-it vector :default gensym)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2986 (Assert (eq gensym (find 'not-in-it bit-vector :default gensym)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2987 (Assert (eq gensym (find 'not-in-it string :default gensym)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2988 (Assert (eq 'hi-there (find 'hi-there list)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2989 ;; Different uninterned symbols with the same name.
5339 ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2990 (Assert (not (eq '#1=#:everyone (find '#1# list))))
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2991
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2992 ;; Test concatenate.
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2993 (Assert (equal list (concatenate 'list vector)))
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2994 (Assert (equal list (concatenate 'list (subseq vector 0 4)
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2995 (subseq list 4))))
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2996 (Assert (equal vector (concatenate 'vector list)))
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2997 (Assert (equal vector (concatenate `(vector * ,(length vector)) list)))
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2998 (Assert (equal string (concatenate `(vector character ,(length string))
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2999 (append string nil))))
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	3000 (Assert (equal bit-vector (concatenate 'bit-vector (subseq bit-vector 0 4)
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	3001 (append (subseq bit-vector 4) nil))))
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	3002 (Assert (equal bit-vector (concatenate `(vector bit ,(length bit-vector))
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	3003 (subseq bit-vector 0 4)
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	3004 (append (subseq bit-vector 4) nil)))))
5336 287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	3005
5353 38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	3006 ;;-----------------------------------------------------
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	3007 ;; Test `block', `return-from'
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	3008 ;;-----------------------------------------------------
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	3009 (Assert (eql 1 (block outer
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	3010 (flet ((outtahere (n) (return-from outer n)))
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	3011 (block outer (outtahere 1)))
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	3012 2))
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	3013 "checking `block' and `return-from' are lexically scoped correctly")
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	3014
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	3015 ;; Other tests are available in Paul Dietz' test suite, and pass. The above,
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	3016 ;; which we used to fail, is based on a test in the Hyperspec. We still
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	3017 ;; behave incorrectly when compiled for the contorted-example function of
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	3018 ;; CLTL2, whence the following test:
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	3019
5576 071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	3020 (labels ((needs-lexical-context (first second third)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	3021 (if (eql 0 first)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	3022 (funcall second)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	3023 (block awkward
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	3024 (+ 5 (needs-lexical-context
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	3025 (1- first)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	3026 third
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	3027 #'(lambda () (return-from awkward 0)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	3028 first)))))
5595 391d809fa4e9 Update tests that have started failing because of changed design decisions. Aidan Kehoe <kehoea@parhasard.net> parents: 5576 diff changeset	3029 (Known-Bug-Expect-Failure
391d809fa4e9 Update tests that have started failing because of changed design decisions. Aidan Kehoe <kehoea@parhasard.net> parents: 5576 diff changeset	3030 (Assert (eql 0 (needs-lexical-context 2 nil nil))
391d809fa4e9 Update tests that have started failing because of changed design decisions. Aidan Kehoe <kehoea@parhasard.net> parents: 5576 diff changeset	3031 "the function special operator doesn't create a lexical context.")))
5353 38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	3032
5642 5bda701e9e7c Be more careful about non-quoted-symbol TAGs, #'byte-compile-catch Aidan Kehoe <kehoea@parhasard.net> parents: 5595 diff changeset	3033 (Assert (eql 10 (catch ':keyword (+ (catch :keyword (throw :keyword 9)) 1)))
5bda701e9e7c Be more careful about non-quoted-symbol TAGs, #'byte-compile-catch Aidan Kehoe <kehoea@parhasard.net> parents: 5595 diff changeset	3034 "checking `byte-compile-catch' doesn't strip keyword TAGs")
5bda701e9e7c Be more careful about non-quoted-symbol TAGs, #'byte-compile-catch Aidan Kehoe <kehoea@parhasard.net> parents: 5595 diff changeset	3035
5462 97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	3036 ;; Test symbol-macrolet with symbols with identical string names.
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	3037
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	3038 (macrolet
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	3039 ((test-symbol-macrolet ()
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	3040 (let* ((symbol 'my-symbol)
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	3041 (copy-symbol (copy-symbol symbol))
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	3042 (third (copy-symbol copy-symbol)))
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	3043 `(symbol-macrolet ((,symbol [symbol expansion])
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	3044 (,copy-symbol [copy expansion])
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	3045 (,third [third expansion]))
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	3046 (list ,symbol ,copy-symbol ,third)))))
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	3047 (Assert (equal '([symbol expansion] [copy expansion] [third expansion])
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	3048 (test-symbol-macrolet))))
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	3049
5550 b908c7265a2b Add the #'apply-partially API, as used by GNU. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	3050 ;; Basic tests of #'apply-partially.
b908c7265a2b Add the #'apply-partially API, as used by GNU. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	3051 (let* ((four 4)
b908c7265a2b Add the #'apply-partially API, as used by GNU. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	3052 (times-four (apply-partially '* four))
5553 62edcc6a11ec Add an assertion about argument order to #'apply-partially compiler macro Aidan Kehoe <kehoea@parhasard.net> parents: 5550 diff changeset	3053 (plus-twelve (apply-partially '+ 6 (* 3 2)))
62edcc6a11ec Add an assertion about argument order to #'apply-partially compiler macro Aidan Kehoe <kehoea@parhasard.net> parents: 5550 diff changeset	3054 (construct-list (apply-partially 'list (incf four) (incf four)
5737 165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3055 (incf four)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3056 (list-and-multiply
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3057 (apply-partially #'(lambda (a b c d &optional e)
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3058 (cons (apply #'+ a b c d (if e (list e)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3059 (list* a b c d e)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3060 ;; Constant arguments -> function can be
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3061 ;; constructed at compile time
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3062 1 2 3))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3063 (list-and-four
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3064 (apply-partially #'(lambda (a b c d &optional e)
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3065 (cons (apply #'+ a b c d (if e (list e)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3066 (list* a b c d e)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3067 ;; Not constant arguments -> function constructed
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3068 ;; at runtime.
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3069 1 2 four)))
5550 b908c7265a2b Add the #'apply-partially API, as used by GNU. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	3070 (Assert (eql (funcall times-four 6) 24))
b908c7265a2b Add the #'apply-partially API, as used by GNU. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	3071 (Assert (eql (funcall times-four 4 4) 64))
b908c7265a2b Add the #'apply-partially API, as used by GNU. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	3072 (Assert (eql (funcall plus-twelve (funcall times-four 4) 4 4) 36))
5553 62edcc6a11ec Add an assertion about argument order to #'apply-partially compiler macro Aidan Kehoe <kehoea@parhasard.net> parents: 5550 diff changeset	3073 (Check-Error wrong-number-of-arguments (apply-partially))
5737 165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3074 (Assert (equal (funcall construct-list) '(5 6 7)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3075 (Assert (equal (funcall list-and-multiply 5 6) '(17 1 2 3 5 . 6)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3076 (Assert (equal (funcall list-and-multiply 7) '(13 1 2 3 7)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3077 (Check-Error wrong-number-of-arguments
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3078 (funcall list-and-multiply 7 8 9 10))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3079 (Assert (equal (funcall list-and-four 5 6) '(21 1 2 7 5 . 6)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3080 (Assert (equal (funcall list-and-four 7) '(17 1 2 7 7)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3081 (Check-Error wrong-number-of-arguments
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	3082 (funcall list-and-four 7 8 9 10)))
5550 b908c7265a2b Add the #'apply-partially API, as used by GNU. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	3083
5852 e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3084 ;; Test #'substitute. Paul Dietz has much more comprehensive tests.
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3085
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3086 (Assert (equal (substitute 'a 'b '(a b c d e f g)) '(a a c d e f g)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3087 (Assert (equal (substitute 'a 'b '(a b c d e b f g) :from-end t :count 1)
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3088 '(a b c d e a f g)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3089
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3090 (Assert (equal (let* ((nomodif '(a b c a b d a c b a e))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3091 (x (copy-list nomodif))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3092 (y (substitute 'z 'a x)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3093 (and (equal nomodif x) y))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3094 '(z b c z b d z c b z e)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3095 (Assert (equal (let* ((nomodif '(a b c a b d a c b a e))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3096 (x (copy-list nomodif))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3097 (y (substitute 'z 'a x :count nil)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3098 (and (equal nomodif x) y))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3099 '(z b c z b d z c b z e)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3100 (Assert (equal (let* ((nomodif '(a b c a b d a c b a e))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3101 (x (copy-list nomodif))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3102 (y (substitute 'z 'a x :key nil)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3103 (and (equal nomodif x) y))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3104 '(z b c z b d z c b z e)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3105 (Assert (equal (let* ((nomodif '(a b c a b d a c b a e))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3106 (x (copy-list nomodif))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3107 (y (substitute 'z 'a x :count 100)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3108 (and (equal nomodif x) y))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3109 '(z b c z b d z c b z e)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3110 (Assert (equal (let* ((nomodif '(a b c a b d a c b a e))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3111 (x (copy-list nomodif))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3112 (y (substitute 'z 'a x :count 0)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3113 (and (equal nomodif x) y))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3114 '(a b c a b d a c b a e)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3115 (Assert (equal (let* ((nomodif '(a b c a b d a c b a e))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3116 (x (copy-list nomodif))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3117 (y (substitute 'z 'a x :count 1)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3118 (and (equal nomodif x) y))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3119 '(z b c a b d a c b a e)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3120 (Assert (equal (let* ((nomodif '(a b c a b d a c b a e))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3121 (x (copy-list nomodif))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3122 (y (substitute 'z 'c x :count 1)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3123 (and (equal nomodif x) y))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3124 '(a b z a b d a c b a e)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3125 (Assert (equal (let* ((nomodif '(a b c a b d a c b a e))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3126 (x (copy-list nomodif))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3127 (y (substitute 'z 'a x :from-end t)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3128 (and (equal nomodif x) y))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3129 '(z b c z b d z c b z e)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3130 (Assert (equal (let* ((nomodif '(a b c a b d a c b a e))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3131 (x (copy-list nomodif))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3132 (y (substitute 'z 'a x :from-end t :count 1)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3133 (and (equal nomodif x) y))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3134 '(a b c a b d a c b z e)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3135 (Assert (equal (let* ((nomodif '(a b c a b d a c b a e))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3136 (x (copy-list nomodif))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3137 (y (substitute 'z 'a x :from-end t :count 4)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3138 (and (equal nomodif x) y))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3139 '(z b c z b d z c b z e)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3140 (Assert (equal (multiple-value-list
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3141 (let* ((nomodif '(a b c a b d a c b a e))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3142 (x (copy-list nomodif)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3143 (values
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3144 (loop for i from 0 to 10
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3145 collect (substitute 'z 'a x :start i))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3146 (equal nomodif x))))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3147 '(((z b c z b d z c b z e) (a b c z b d z c b z e)
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3148 (a b c z b d z c b z e) (a b c z b d z c b z e)
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3149 (a b c a b d z c b z e) (a b c a b d z c b z e)
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3150 (a b c a b d z c b z e) (a b c a b d a c b z e)
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3151 (a b c a b d a c b z e) (a b c a b d a c b z e)
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3152 (a b c a b d a c b a e))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3153 t)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3154 (Assert (equal (multiple-value-list
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3155 (let* ((nomodif '(a b c a b d a c b a e))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3156 (x (copy-list nomodif)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3157 (values
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3158 (loop for i from 0 to 10
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3159 collect (substitute 'z 'a x :start i :end nil))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3160 (equal nomodif x))))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3161 '(((z b c z b d z c b z e) (a b c z b d z c b z e)
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3162 (a b c z b d z c b z e) (a b c z b d z c b z e)
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3163 (a b c a b d z c b z e) (a b c a b d z c b z e)
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3164 (a b c a b d z c b z e) (a b c a b d a c b z e)
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3165 (a b c a b d a c b z e) (a b c a b d a c b z e)
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3166 (a b c a b d a c b a e))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3167 t)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3168 (Assert (equal
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3169 (let* ((nomodif '(1 2 3 2 6 1 2 4 1 3 2 7))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3170 (x (copy-list nomodif))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3171 (y (substitute 300 1 x :key #'1-)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3172 (and (equal nomodif x) y))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3173 '(1 300 3 300 6 1 300 4 1 3 300 7)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3174
5574 d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3175 ;; Test labels and inlining.
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3176 (labels
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3177 ((+ (&rest arguments)
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3178 ;; Shades of Java, hah.
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3179 (mapconcat #'prin1-to-string arguments ", "))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3180 (print-with-commas (stream one two three four five)
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3181 (princ (+ one two three four five) stream))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3182 (bookend (open close &rest arguments)
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3183 (refer-to-bookend (concat open (apply #'+ arguments) close)))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3184 (refer-to-bookend (string)
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3185 (bookend "[" "]" string "hello" "there")))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3186 (declare (inline + print-with-commas bookend refer-to-bookend))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3187 (macrolet
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3188 ((with-first-arguments (&optional form)
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3189 (append form (list 1 [hi there] 40 "this is a string" pi)))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3190 (with-second-arguments (&optional form)
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3191 (append form (list pi e ''hello ''there [40 50 60])))
5658 289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3192 (with-both-arguments (&optional form &environment env)
5574 d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3193 (append form
5658 289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3194 (macroexpand '(with-first-arguments) env)
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3195 (macroexpand '(with-second-arguments) env))))
5574 d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3196
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3197 (with-temp-buffer
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3198 (Assert
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3199 (equal
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3200 (mapconcat #'prin1-to-string (with-first-arguments (list)) ", ")
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3201 (with-first-arguments (print-with-commas (current-buffer))))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3202 "checking print-with-commas gives the expected result")
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3203 (Assert
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3204 (or
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3205 (not (compiled-function-p (indirect-function #'print-with-commas)))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3206 (notany #'compiled-function-p
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3207 (compiled-function-constants
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3208 (indirect-function #'print-with-commas))))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3209 "checking the label + was inlined correctly")
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3210 (insert ", ")
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3211 ;; This call to + will be inline in compiled code, but there's
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3212 ;; no easy way for us to check that:
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3213 (Assert (null (insert (with-second-arguments (+)))))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3214 (Assert (equal
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3215 (mapconcat #'prin1-to-string (with-both-arguments (list)) ", ")
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3216 (buffer-string))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3217 "checking the buffer contents are as expected at the end.")
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3218 (Assert (not (funcall (intern "eq") #'bookend #'refer-to-bookend))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3219 "checking two mutually recursive functions compiled OK"))))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3220
5658 289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3221 ;; Test macroexpand's handling of the ENVIRONMENT argument. We augmented it
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3222 ;; quietly for about four months, and this was incorrect.
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3223
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3224 (Check-Error
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3225 void-variable
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3226 (macrolet
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3227 ((with-first-arguments (&optional form)
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3228 (append form (list 1 [hi there] 40 "this is a string" pi)))
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3229 (with-second-arguments (&optional form)
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3230 (append form (list pi e ''hello ''there [40 50 60])))
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3231 (with-both-arguments (&optional form)
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3232 (append form
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3233 (macroexpand '(with-first-arguments))
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3234 (macroexpand '(with-second-arguments)))))
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3235 (with-both-arguments (list))))
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3236
5769 ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3237 ;; Test arithmetic comparisons of markers and operations on markers. Most
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3238 ;; relevant with Mule, but also worth doing on non-Mule.
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3239 (let ((character (if (featurep 'mule) (decode-char 'ucs #x20ac) ?\xff))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3240 (translation (make-char-table 'generic))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3241 markers fixnums)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3242 (macrolet
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3243 ((Assert-arith-equivalences (markers context)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3244 `(progn
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3245 (Assert (apply #'> markers)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3246 ,(concat "checking #'> correct with long arguments list, "
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3247 context))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3248 (Assert 0 ,context)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3249 (Assert (apply #'< (reverse markers))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3250 ,(concat "checking #'< correct with long arguments list, "
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3251 context))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3252 (map-plist #'(lambda (object1 object2)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3253 (Assert (> object1 object2)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3254 ,(concat
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3255 "checking markers correctly ordered, >, "
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3256 context))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3257 (Assert (< object2 object1)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3258 ,(concat
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3259 "checking markers correctly ordered, <, "
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3260 context)))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3261 markers)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3262 ;; OK, so up to this point there has been no need for byte-char
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3263 ;; conversion. The following requires it, though:
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3264 (map-plist #'(lambda (object1 object2)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3265 (Assert
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3266 (= (max object1 object2) object1)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3267 ,(concat
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3268 "checking max correct, two markers, " context))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3269 (Assert
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3270 (= (min object1 object2) object2)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3271 ,(concat
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3272 "checking min, correct, two markers, " context))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3273 ;; It is probably reasonable to change this design
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3274 ;; decision.
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3275 (Assert
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3276 (fixnump (max object1 object2))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3277 ,(concat
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3278 "checking fixnum conversion as documented, max, "
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3279 context))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3280 (Assert
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3281 (fixnump (min object1 object2))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3282 ,(concat
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3283 "checking fixnum conversion as documented, min, "
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3284 context)))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3285 markers))))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3286 (with-temp-buffer
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3287 (loop for ii from 0 to 100
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3288 do (progn
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3289 (insert " " character " " character " " character " "
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3290 character "\n")
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3291 (insert character)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3292 (push (copy-marker (1- (point)) t) markers)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3293 (insert ?\x20)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3294 (push (copy-marker (1- (point)) t) markers)))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3295 (Assert-arith-equivalences markers "with Euro sign")
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3296 ;; Save the markers as fixnum character positions:
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3297 (setq fixnums (mapcar #'marker-position markers))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3298 ;; Check that the equivalences work with the fixnums, while we
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3299 ;; have them:
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3300 (Assert-arith-equivalences fixnums "fixnums, with Euro sign")
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3301 ;; Now, transform the characters that may be problematic to ASCII,
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3302 ;; check our equivalences still hold.
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3303 (put-char-table character ?\x7f translation)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3304 (translate-region (point-min) (point-max) translation)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3305 ;; Sigh, restore the markers #### shouldn't the insertion and
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3306 ;; deletion code do this?!
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3307 (map nil #'set-marker markers fixnums)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3308 (Assert-arith-equivalences markers "without Euro sign")
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3309 ;; Restore the problematic character.
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3310 (put-char-table ?\x7f character translation)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3311 (translate-region (point-min) (point-max) translation)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3312 (map nil #'set-marker markers fixnums)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3313 (Assert-arith-equivalences markers "with Euro sign restored"))))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3314
5772 cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3315 ;;-----------------------------------------------------
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3316 ;; Test #'write-sequence and friends.
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3317 ;;-----------------------------------------------------
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3318
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3319 (macrolet
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3320 ((Assert-write-results (function context &key short-string long-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3321 sequences-too output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3322 clear-output get-last-output)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3323 "Check correct output in CONTEXT for `write-sequence' and friends."
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3324 (let* ((short-bit-vector (map 'bit-vector #'logand short-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3325 (make-circular-list 1 1)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3326 (long-bit-vector (map 'bit-vector #'logand long-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3327 (make-circular-list 1 1)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3328 (short-bit-vector-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3329 (map #'string #'int-char short-bit-vector))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3330 (long-bit-vector-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3331 (map #'string #'int-char long-bit-vector)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3332 `(progn
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3333 (,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3334 (,function ,short-string ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3335 (Assert (equal ,short-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3336 (,get-last-output ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3337 ,(length short-string)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3338 ,(format "checking %s with short string, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3339 function context))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3340 ,@(when sequences-too
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3341 `((,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3342 (,function ,(vconcat short-string) ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3343 (Assert (equal ,short-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3344 (,get-last-output ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3345 ,(length short-string)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3346 ,(format "checking %s with short vector, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3347 function context))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3348 (,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3349 (,function ',(append short-string nil) ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3350 (Assert (equal ,short-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3351 (,get-last-output ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3352 ,(length short-string)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3353 ,(format "checking %s with short list, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3354 function context))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3355 (,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3356 (,function ,short-bit-vector ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3357 (Assert (equal ,short-bit-vector-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3358 (,get-last-output
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3359 ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3360 ,(length short-bit-vector-string)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3361 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3362 "checking %s with short bit-vector, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3363 function context))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3364 (,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3365 (,function ,long-bit-vector ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3366 (Assert (equal ,long-bit-vector-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3367 (,get-last-output
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3368 ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3369 ,(length long-bit-vector-string)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3370 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3371 "checking %s with long bit-vector, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3372 function context))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3373 ,(cons
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3374 'progn
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3375 (loop
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3376 for (subseq-start subseq-end description)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3377 in `((0 ,(length short-string) "trivial range")
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3378 (4 7 "harder range"))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3379 nconc
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3380 `((,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3381 (,function ,short-string ,output-stream :start ,subseq-start
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3382 :end ,subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3383 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3384 (equal ,(subseq short-string subseq-start subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3385 (,get-last-output ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3386 ,(- subseq-end subseq-start)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3387 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3388 "checking %s with short string, %s, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3389 function context description))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3390 ,@(when sequences-too
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3391 `((,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3392 (,function ,(vconcat short-string) ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3393 :start ,subseq-start :end ,subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3394 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3395 (equal ,(subseq short-string subseq-start subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3396 (,get-last-output ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3397 ,(- subseq-end subseq-start)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3398 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3399 "checking %s with short vector, %s, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3400 function context description))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3401 (,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3402 (,function ',(append short-string nil) ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3403 :start ,subseq-start :end ,subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3404 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3405 (equal ,(subseq short-string subseq-start subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3406 (,get-last-output
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3407 ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3408 ,(- subseq-end subseq-start )))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3409 ,(format "checking %s with short list, %s, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3410 function context description))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3411 (,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3412 (,function ,short-bit-vector ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3413 :start ,subseq-start :end ,subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3414 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3415 (equal ,(subseq short-bit-vector-string subseq-start
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3416 subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3417 (,get-last-output ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3418 ,(- subseq-end subseq-start)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3419 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3420 "checking %s with short bit-vector, %s, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3421 function context description)))))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3422 ,(cons
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3423 'progn
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3424 (loop
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3425 for (subseq-start subseq-end description)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3426 in `((0 ,(length long-string) "trivial range")
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3427 (4 90 "harder range"))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3428 nconc
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3429 `((,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3430 (,function ,long-string ,output-stream :start ,subseq-start
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3431 :end ,subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3432 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3433 (equal ,(subseq long-string subseq-start subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3434 (,get-last-output ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3435 ,(- subseq-end subseq-start)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3436 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3437 "checking %s with long string, %s, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3438 function context description))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3439 ,@(when sequences-too
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3440 `((,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3441 (,function ,(vconcat long-string) ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3442 :start ,subseq-start :end ,subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3443 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3444 (equal ,(subseq long-string subseq-start subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3445 (,get-last-output
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3446 ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3447 ,(- subseq-end subseq-start)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3448 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3449 "checking %s with long vector, %s, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3450 function context description))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3451 (,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3452 (,function ',(append long-string nil) ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3453 :start ,subseq-start :end ,subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3454 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3455 (equal ,(subseq long-string subseq-start subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3456 (,get-last-output ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3457 ,(- subseq-end subseq-start)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3458 ,(format "checking %s with long list, %s, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3459 function context description))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3460 (,clear-output ,output-stream)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3461 (,function ,long-bit-vector ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3462 :start ,subseq-start :end ,subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3463 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3464 (equal ,(subseq long-bit-vector-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3465 subseq-start subseq-end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3466 (,get-last-output
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3467 ,output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3468 ,(- subseq-end subseq-start)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3469 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3470 "checking %s with long bit-vector, %s, %s"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3471 function context description)))))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3472 (,clear-output ,output-stream))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3473 (test-write-string (function &key sequences-too worry-about-newline)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3474 (let* ((short-string "hello there")
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3475 (long-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3476 (decode-coding-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3477 (concat
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3478 "\xd8\xb3\xd9\x84\xd8\xa7\xd9\x85 \xd8\xb9\xd9\x84"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3479 "\xdb\x8c\xda\xa9\xd9\x85\x2c \xd8\xa7\xd8\xb3\xd9"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3480 "\x85 \xd9\x85\xd9\x86 \xd8\xa7\xdb\x8c\xd8\xaf\xd9"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3481 "\x86 \xda\xa9\xdb\x8c\xd9\x88 \xd8\xa7\xd8\xb3\xd8"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3482 "\xaa\x2e \xd9\x85\xd9\x86 \xd8\xa7\xdb\x8c\xd8\xb1"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3483 "\xd9\x84\xd9\x86\xd8\xaf\xdb\x8c \xd8\xa7\xd9\x85"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3484 "\x2c \xd9\x88 \xd9\x85\xd9\x86 \xd8\xaf\xd8\xb1 "
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3485 "\xd8\xa8\xdb\x8c\xd9\x85\xd8\xa7\xd8\xb1\xd8\xb3"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3486 "\xd8\xaa\xd8\xa7\xd9\x86 \xda\xa9\xd8\xa7\xd8\xb1"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3487 "\xd9\x85\xdb\x8c\xe2\x80\x8c\xda\xa9\xd9\x86\xd9"
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3488 "\x85\x2e")
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3489 (if (featurep 'mule) 'utf-8 'raw-text-unix)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3490 (long-string (concat long-string long-string long-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3491 long-string long-string long-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3492 long-string long-string long-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3493 long-string long-string long-string)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3494 `(with-temp-buffer
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3495 (let* ((long-string ,long-string)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3496 (stashed-data
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3497 (get-buffer-create
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3498 (generate-new-buffer-name " stash")))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3499 (function-output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3500 (apply-partially
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3501 #'(lambda (buffer character)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3502 (insert-char character 1 nil buffer))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3503 stashed-data))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3504 (marker-buffer
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3505 (get-buffer-create
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3506 (generate-new-buffer-name " for-marker")))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3507 (marker-base-position 40)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3508 (marker
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3509 (progn
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3510 (insert-char ?\xff 90 nil marker-buffer)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3511 (set-marker (make-marker) 40 marker-buffer))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3512 (unwind-protect
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3513 (labels
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3514 ((clear-buffer (buffer)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3515 (delete-region (point-min buffer) (point-max buffer)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3516 buffer))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3517 (clear-stashed-data (ignore)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3518 (delete-region (point-min stashed-data)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3519 (point-max stashed-data)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3520 stashed-data))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3521 (clear-marker-data (marker)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3522 (delete-region marker-base-position marker
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3523 (marker-buffer marker)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3524 (buffer-output (buffer length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3525 (and (> (point buffer) length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3526 (buffer-substring (- (point buffer) length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3527 (point buffer) buffer)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3528 (stashed-data-output (ignore length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3529 (and (> (point stashed-data) length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3530 (buffer-substring (- (point stashed-data)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3531 length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3532 (point stashed-data)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3533 stashed-data)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3534 (marker-data (marker length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3535 (and (> marker length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3536 (buffer-substring (- marker length) marker
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3537 (marker-buffer marker))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3538 (buffer-output-sans-newline (buffer length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3539 (and (> (point buffer) (+ length 1))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3540 (buffer-substring (- (point buffer) length 1)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3541 (1- (point buffer)))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3542 (stashed-data-output-sans-newline (ignore length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3543 (and (> (point stashed-data) (+ length 1))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3544 (buffer-substring (- (point stashed-data)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3545 length 1)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3546 (1- (point stashed-data))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3547 stashed-data)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3548 (marker-data-sans-newline (marker length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3549 (and (> marker (+ length 1))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3550 (buffer-substring (- marker length 1)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3551 (1- marker)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3552 (marker-buffer marker)))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3553 (Check-Error wrong-number-of-arguments (,function))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3554 (,(if (subrp (symbol-function function))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3555 'progn
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3556 'Implementation-Incomplete-Expect-Failure)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3557 (Check-Error wrong-number-of-arguments
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3558 (,function ,short-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3559 (current-buffer) :start))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3560 (Check-Error wrong-number-of-arguments
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3561 (,function ,short-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3562 (current-buffer) :start 0
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3563 :end nil :start)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3564 (Check-Error invalid-keyword-argument
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3565 (,function ,short-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3566 (current-buffer)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3567 :test #'eq))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3568 (Check-Error wrong-type-argument (,function pi))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3569 ,@(if sequences-too
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3570 `((Check-Error
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3571 args-out-of-range
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3572 (,function (vector most-positive-fixnum)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3573 (Check-Error
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3574 args-out-of-range
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3575 (,function (list most-positive-fixnum)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3576 ,@(if (featurep 'mule)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3577 `((Check-Error
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3578 args-out-of-range
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3579 (,function
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3580 (vector
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3581 (char-int
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3582 (decode-char 'ucs #x20ac))))))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3583 `((Check-Error wrong-type-argument
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3584 (,function
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3585 ',(append short-string nil)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3586 (Check-Error wrong-type-argument
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3587 (,function
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3588 ,(vconcat long-string)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3589 (Check-Error wrong-type-argument
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3590 (,function #*010010001010101))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3591 (Check-Error wrong-type-argument
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3592 (,function ,short-string (current-buffer)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3593 :start 0.0))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3594 (Check-Error wrong-type-argument
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3595 (,function ,short-string (current-buffer)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3596 :end 4.0))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3597 (Check-Error invalid-function
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3598 (,function ,short-string pi))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3599 (Check-Error args-out-of-range
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3600 (,function ,short-string (current-buffer)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3601 :end ,(1+ (length short-string))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3602 (Check-Error args-out-of-range
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3603 (,function ,short-string nil
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3604 :start
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3605 ,(1+ (length short-string))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3606 ;; Not checked here; output to a stdio stream, output
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3607 ;; to an lstream, output to a frame.
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3608 (Assert-write-results
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3609 ,function "buffer point" :short-string ,short-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3610 :long-string ,long-string :sequences-too ,sequences-too
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3611 :output-stream (current-buffer)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3612 :clear-output clear-buffer
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3613 :get-last-output
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3614 ,(if worry-about-newline 'buffer-output-sans-newline
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3615 'buffer-output))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3616 (Assert-write-results
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3617 ,function "function output" :short-string ,short-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3618 :long-string ,long-string :sequences-too ,sequences-too
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3619 :output-stream function-output-stream
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3620 :clear-output clear-stashed-data
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3621 :get-last-output
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3622 ,(if worry-about-newline
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3623 'stashed-data-output-sans-newline
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3624 'stashed-data-output))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3625 (Assert-write-results
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3626 ,function "marker output" :short-string ,short-string
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3627 :long-string ,long-string :sequences-too ,sequences-too
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3628 :output-stream marker :clear-output clear-marker-data
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3629 :get-last-output ,(if worry-about-newline
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3630 'marker-data-sans-newline
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3631 'marker-data)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3632 (kill-buffer stashed-data)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3633 (kill-buffer marker-buffer)))))))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3634 (test-write-string write-sequence :sequences-too t)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3635 (test-write-string write-string :sequences-too nil)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3636 (test-write-string write-line :worry-about-newline t :sequences-too nil))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3637
5864 750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3638 ;;-----------------------------------------------------
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3639 ;; Test #'parse-integer and friends.
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3640 ;;-----------------------------------------------------
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3641
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3642 (Check-Error wrong-type-argument (parse-integer 123456789))
5867 e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3643
5864 750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3644 (if (featurep 'bignum)
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3645 (progn
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3646 (Check-Error args-out-of-range
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3647 (parse-integer "123456789" :start (1+ most-positive-fixnum)))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3648 (Check-Error args-out-of-range
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3649 (parse-integer "123456789" :end (1+ most-positive-fixnum))))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3650 (Check-Error wrong-type-argument
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3651 (parse-integer "123456789" :start (1+ most-positive-fixnum)))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3652 (Check-Error wrong-type-argument
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3653 (parse-integer "123456789" :end (1+ most-positive-fixnum))))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3654
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3655 (Check-Error args-out-of-range (parse-integer "123456789" :radix -1))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3656 (Check-Error args-out-of-range
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3657 (parse-integer "123456789" :radix (1+ most-positive-fixnum)))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3658 (Check-Error wrong-number-of-arguments
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3659 (parse-integer "123456789" :junk-allowed))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3660 (Check-Error invalid-keyword-argument
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3661 (parse-integer "123456789" :no-such-keyword t))
5867 e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3662 (Check-Error wrong-type-argument (parse-integer "123456789" :start -1))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3663 (Check-Error invalid-argument (parse-integer "abc"))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3664 (Check-Error invalid-argument (parse-integer "efz" :radix 16))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3665
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3666 (macrolet
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3667 ((with-digits (ascii alternate script)
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3668 (let ((tree-alist (list (cons 'old 'new)))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3669 (text-alist (mapcar* #'cons ascii alternate)))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3670 (list*
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3671 'progn
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3672 (cons
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3673 'progn
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3674 (loop for ascii-digit across ascii
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3675 for non-ascii across alternate
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3676 collect `(Assert (eql (digit-char-p ,non-ascii)
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3677 ,(- ascii-digit ?0))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3678 ,(concat "checking `digit-char-p', base-10, "
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3679 script))))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3680 (sublis
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3681 tree-alist
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3682 '((Assert (equal (multiple-value-list
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3683 (parse-integer " -123 "))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3684 '(-123 7)))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3685 (Assert (equal (multiple-value-list
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3686 (parse-integer "-3efz" :radix 16
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3687 :junk-allowed t))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3688 '(-1007 4)))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3689 (Assert (equal (multiple-value-list
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3690 (parse-integer "zzef9" :radix 16 :start 2))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3691 '(3833 5)))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3692 (Assert (equal (multiple-value-list
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3693 (parse-integer "0123456789" :radix 8
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3694 :junk-allowed t))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3695 '(342391 8)))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3696 (Assert (equal (multiple-value-list
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3697 (parse-integer "":junk-allowed t))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3698 '(nil 0)))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3699 (Assert (equal (multiple-value-list
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3700 (parse-integer "abc" :junk-allowed t))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3701 '(nil 0)))
5886 c96000075e49 Be more careful about C integer overflow, #'parse-integer. Aidan Kehoe <kehoea@parhasard.net> parents: 5867 diff changeset	3702 (Assert (eql (ignore-errors (parse-integer "100000000"
c96000075e49 Be more careful about C integer overflow, #'parse-integer. Aidan Kehoe <kehoea@parhasard.net> parents: 5867 diff changeset	3703 :radix 16))
c96000075e49 Be more careful about C integer overflow, #'parse-integer. Aidan Kehoe <kehoea@parhasard.net> parents: 5867 diff changeset	3704 (if (featurep 'bignum) (lsh 1 32) nil))
c96000075e49 Be more careful about C integer overflow, #'parse-integer. Aidan Kehoe <kehoea@parhasard.net> parents: 5867 diff changeset	3705 "checking an overflow bug has been fixed")
c96000075e49 Be more careful about C integer overflow, #'parse-integer. Aidan Kehoe <kehoea@parhasard.net> parents: 5867 diff changeset	3706 (Assert (eql (ignore-errors (parse-integer "-100000000"
c96000075e49 Be more careful about C integer overflow, #'parse-integer. Aidan Kehoe <kehoea@parhasard.net> parents: 5867 diff changeset	3707 :radix 16))
5905 85fd1ab80057 Fix a bug in #'parse-integer with negative bignums and non-nil JUNK-ALLOWED Aidan Kehoe <kehoea@parhasard.net> parents: 5893 diff changeset	3708 (if (featurep 'bignum) (- (lsh 1 32)) nil))
5886 c96000075e49 Be more careful about C integer overflow, #'parse-integer. Aidan Kehoe <kehoea@parhasard.net> parents: 5867 diff changeset	3709 "checking an overflow bug has been fixed, negative int")
5905 85fd1ab80057 Fix a bug in #'parse-integer with negative bignums and non-nil JUNK-ALLOWED Aidan Kehoe <kehoea@parhasard.net> parents: 5893 diff changeset	3710 (Assert (eql (ignore-errors (parse-integer
85fd1ab80057 Fix a bug in #'parse-integer with negative bignums and non-nil JUNK-ALLOWED Aidan Kehoe <kehoea@parhasard.net> parents: 5893 diff changeset	3711 (format "%d4/" most-negative-fixnum)
85fd1ab80057 Fix a bug in #'parse-integer with negative bignums and non-nil JUNK-ALLOWED Aidan Kehoe <kehoea@parhasard.net> parents: 5893 diff changeset	3712 :junk-allowed t))
85fd1ab80057 Fix a bug in #'parse-integer with negative bignums and non-nil JUNK-ALLOWED Aidan Kehoe <kehoea@parhasard.net> parents: 5893 diff changeset	3713 (if (featurep 'bignum)
85fd1ab80057 Fix a bug in #'parse-integer with negative bignums and non-nil JUNK-ALLOWED Aidan Kehoe <kehoea@parhasard.net> parents: 5893 diff changeset	3714 (- (* most-negative-fixnum 10) 4)
85fd1ab80057 Fix a bug in #'parse-integer with negative bignums and non-nil JUNK-ALLOWED Aidan Kehoe <kehoea@parhasard.net> parents: 5893 diff changeset	3715 nil))
85fd1ab80057 Fix a bug in #'parse-integer with negative bignums and non-nil JUNK-ALLOWED Aidan Kehoe <kehoea@parhasard.net> parents: 5893 diff changeset	3716 "checking a bug with :junk-allowed, negative bignum")
5867 e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3717 (Check-Error invalid-argument (parse-integer "0123456789"
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3718 :radix 8))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3719 (Check-Error invalid-argument (parse-integer "abc"))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3720 (Check-Error invalid-argument (parse-integer "efz" :radix 16))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3721
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3722 ;; In contravention of Common Lisp, we allow both 0 and 1 as
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3723 ;; values for RADIX, useless as that is.
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3724 (Assert (equal (multiple-value-list
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3725 (parse-integer "00000" :radix 1)) '(0 5))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3726 "checking 1 is allowed as a value for RADIX")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3727 (Assert (equal (multiple-value-list
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3728 (parse-integer "" :radix 0 :junk-allowed t))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3729 '(nil 0))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3730 "checking 0 is allowed as a value for RADIX"))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3731 :test #'(lambda (new old)
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3732 ;; This function replaces any ASCII decimal digits in
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3733 ;; any string encountered in the tree with the
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3734 ;; non-ASCII digits supplied in ALTERNATE.
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3735 (when (and (stringp old) (find-if #'digit-char-p old))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3736 (setf (cdar tree-alist)
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3737 (concatenate 'string
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3738 (sublis text-alist
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3739 (append old nil))))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3740 t))))))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3741 (repeat-parse-integer-non-ascii ()
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3742 (when (featurep 'mule)
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3743 (cons
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3744 'progn
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3745 (loop for (code-point . script)
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3746 in '((#x0660 . "Arabic-Indic")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3747 (#x06f0 . "Extended Arabic-Indic")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3748 (#x07c0 . "Nko")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3749 (#x0966 . "Devanagari")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3750 (#x09e6 . "Bengali")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3751 (#x0a66 . "Gurmukhi")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3752 (#x0ae6 . "Gujarati")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3753 (#x0b66 . "Oriya")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3754 (#x0be6 . "Tamil")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3755 (#x0c66 . "Telugu")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3756 (#x0ce6 . "Kannada")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3757 (#x0d66 . "Malayalam")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3758 (#x0de6 . "Sinhala Lith")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3759 (#x0e50 . "Thai")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3760 (#x0ed0 . "Lao")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3761 (#x0f20 . "Tibetan")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3762 (#x1040 . "Myanmar")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3763 (#x1090 . "Myanmar Shan")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3764 (#x17e0 . "Khmer")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3765 (#x1810 . "Mongolian")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3766 (#x1946 . "Limbu")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3767 (#x19d0 . "New Tai Lue")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3768 (#x1a80 . "Tai Tham Hora")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3769 (#x1a90 . "Tai Tham Tham")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3770 (#x1b50 . "Balinese")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3771 (#x1bb0 . "Sundanese")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3772 (#x1c40 . "Lepcha")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3773 (#x1c50 . "Ol Chiki")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3774 (#xa620 . "Vai")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3775 (#xa8d0 . "Saurashtra")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3776 (#xa900 . "Kayah Li")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3777 (#xa9d0 . "Javanese")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3778 (#xa9f0 . "Myanmar Tai Laing")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3779 (#xaa50 . "Cham")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3780 (#xabf0 . "Meetei Mayek")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3781 (#xff10 . "Fullwidth")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3782 (#x000104a0 . "Osmanya")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3783 (#x00011066 . "Brahmi")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3784 (#x000110f0 . "Sora Sompeng")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3785 (#x00011136 . "Chakma")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3786 (#x000111d0 . "Sharada")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3787 (#x000112f0 . "Khudawadi")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3788 (#x000114d0 . "Tirhuta")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3789 (#x00011650 . "Modi")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3790 (#x000116c0 . "Takri")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3791 (#x000118e0 . "Warang Citi")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3792 (#x00016a60 . "Mro")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3793 (#x00016b50 . "Pahawh Hmong")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3794 (#x0001d7ce . "Mathematical Bold")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3795 (#x0001d7d8 . "Mathematical Double-Struck")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3796 (#x0001d7e2 . "Mathematical Sans-Serif")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3797 (#x0001d7ec . "Mathematical Sans-Serif Bold")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3798 (#x0001d7f6 . "Mathematical Monospace"))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3799 collect `(with-digits "0123456789"
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3800 ;; All the Unicode decimal digits have contiguous code
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3801 ;; point ranges as documented by the Unicode standard,
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3802 ;; we can just increment.
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3803 ,(concat (loop for fixnum from code-point
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3804 to (+ code-point 9)
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3805 collect (decode-char 'ucs fixnum))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3806 "")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3807 ,script))))))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3808 (with-digits "0123456789" "0123456789" "ASCII")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3809 (repeat-parse-integer-non-ascii))
5864 750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3810
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3811 ;; Next two paragraphs of tests from GNU, thank you Leo Liu.
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3812 (Assert (eql (digit-char-p ?3) 3))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3813 (Assert (eql (digit-char-p ?a 11) 10))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3814 (Assert (eql (digit-char-p ?w 36) 32))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3815 (Assert (not (digit-char-p ?a)))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3816 (Check-Error args-out-of-range (digit-char-p ?a 37))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3817 (Assert (not (digit-char-p ?a 1)))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3818
5867 e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3819 (loop for fixnum from 0 below 36
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3820 do (Assert (eql fixnum (digit-char-p (digit-char fixnum 36) 36))))
5864 750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3821
5867 e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3822 (let ((max -1)
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3823 (min most-positive-fixnum)
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3824 (max-char nil) (min-char nil))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3825 (map-char-table #'(lambda (key value)
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3826 (if (> value max)
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3827 (setf max value
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3828 max-char key))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3829 (if (< value min)
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3830 (setf min value
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3831 min-char key))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3832 nil)
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3833 digit-fixnum-map)
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3834 (Assert (>= 35 max) "checking base 36 is supported, `digit-fixnum-map'")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3835 (Assert (<= min 2) "checking base two supported, `digit-fixnum-map'")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3836 (Assert (eql (digit-char-p max-char (1+ max)) max))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3837 (Assert (eql (digit-char-p min-char (1+ min)) min))
5864 750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3838
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3839 (let ((binary-table
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3840 (copy-char-table #s(char-table :type generic :default -1 :data ()))))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3841 (loop for fixnum from 00 to #xff
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3842 do (put-char-table (int-char fixnum) fixnum binary-table))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3843 (Assert (eql most-positive-fixnum
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3844 (parse-integer
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3845 (concatenate 'string "\x3f"
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3846 (make-string
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3847 (/ (- (integer-length most-positive-fixnum)
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3848 (integer-length #x3f)) 8)
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3849 ?\xff))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3850 :radix-table binary-table :radix #x100))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3851 "checking parsing text using base 256 (big endian binary) works")
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3852 (Assert (equal
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3853 (multiple-value-list
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3854 (parse-integer " \1\7\1\7 " :radix-table binary-table))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3855 '(1717 6))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3856 "checking whitespace treated as such when it is not < radix")
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3857 (Assert (equal
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3858 (multiple-value-list
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3859 (parse-integer " \1\7\1\7 " :radix-table binary-table
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3860 :junk-allowed t))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3861 '(1717 5))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3862 "checking whitespace treated as junk when it is not < radix")
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3863 (Check-Error invalid-argument
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3864 (parse-integer "1234" :radix-table binary-table))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3865 (Assert (equal
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3866 (multiple-value-list
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3867 (parse-integer "--" :radix-table binary-table :radix #x100))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3868 '(-45 2))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3869 "checking ?- always treated as minus sign initially")
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3870 (Assert (equal
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3871 (multiple-value-list
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3872 (parse-integer "+20" :radix-table binary-table :radix #x100))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3873 '(2830896 3))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3874 "checking ?+ not dropped initially if it has integer weight")
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3875 (Assert (eql #xff (digit-char-p ?� #x100 binary-table))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3876 "checking `digit-char-p' behaves correctly with base 256")
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3877 (Assert (eql ?\xff (digit-char #xff #x100 binary-table))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3878 "checking `digit-char' behaves correctly with base 256")
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3879 (Assert (eql (parse-integer " " :radix-table binary-table :radix #x100)
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3880 #x20)
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3881 "checking whitespace not treated as such when it has fixnum weight")
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3882 (Assert (null (digit-char-p ?0 nil binary-table))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3883 "checking `digit-char-p' reflects RADIX-TABLE, ?0")
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3884 (Assert (null (digit-char-p ?9 nil binary-table))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3885 "checking `digit-char-p' reflects RADIX-TABLE, ?9")
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3886 (Assert (null (digit-char-p ?a 16 binary-table))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3887 "checking `digit-char-p' reflects RADIX-TABLE, ?a")
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3888 (Assert (eql ?� (digit-char #xff #x100 binary-table))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3889 "checking `digit-char' reflects RADIX-TABLE, #xff")
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3890 (Assert (eql ?a (digit-char #x61 #x100 binary-table))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3891 "checking `digit-char' reflects RADIX-TABLE, #x61")
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3892 (Assert (null (digit-char #xff nil binary-table))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3893 "checking `digit-char' reflects RADIX-TABLE, #xff, base 10")
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3894 (Assert (eql ?\x0a (digit-char 10 16 binary-table))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3895 "checking `digit-char' reflects RADIX-TABLE, 10, base 16")
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3896 (Assert (eql ?\x09 (digit-char 9 nil binary-table))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3897 "checking `digit-char' reflects RADIX-TABLE, 9, base 10"))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3898
5891 a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3899 ;; Test #'clear-string.
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3900
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3901 (Check-Error wrong-type-argument (clear-string [?\x00 ?\xff]))
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3902 (Check-Error wrong-type-argument (clear-string '(?\x00 ?\xff)))
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3903 (Check-Error wrong-type-argument (clear-string #*1010))
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3904 (Check-Error wrong-number-of-arguments (clear-string "hello" ?*))
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3905
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3906 (let* ((template (concat
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3907 "this is a template string, "
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3908 (if (unicode-to-char #x06af)
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3909 (decode-coding-string
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3910 (concat
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3911 "\xd8\xa8\xd9\x87 \xd9\x86\xd8\xb8\xd8\xb1 "
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3912 "\xd9\x85\xd9\x86 \xd8\xae\xd9\x88\xda\xa9 "
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3913 "\xd8\xae\xd9\x88\xd8\xb4\xd9\x85\xd8\xb2\xd9\x87 "
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3914 "\xd8\xa7\xd8\xb3\xd8\xaa")
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3915 'utf-8))))
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3916 (length (length template))
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3917 (null (make-string length ?\x00)))
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3918 (Assert (null (clear-string (copy-sequence template))))
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3919 (Assert (eql length (let ((string (copy-sequence template)))
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3920 (clear-string string)
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3921 (length string))))
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3922 (Assert (equal null (let ((string (copy-sequence template)))
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3923 (clear-string string)
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3924 string))))
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3925
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3926 ;; No way to check from Lisp whether the data was actually nulled.
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3927
5889 bd644055ef44 Correct a bug in #'check-type, non-setf'able PLACEs Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3928 ;; Check that a bug in #'check-type with non-setfable PLACE (something not
bd644055ef44 Correct a bug in #'check-type, non-setf'able PLACEs Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3929 ;; actually specified by Common Lisp) has been fixed.
bd644055ef44 Correct a bug in #'check-type, non-setf'able PLACEs Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3930 (Assert (prog1 t (check-type 300 fixnum))
bd644055ef44 Correct a bug in #'check-type, non-setf'able PLACEs Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3931 "checking #'check-type OK, fixnum literal PLACE")
bd644055ef44 Correct a bug in #'check-type, non-setf'able PLACEs Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3932 (Check-Error wrong-type-argument
bd644055ef44 Correct a bug in #'check-type, non-setf'able PLACEs Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3933 (check-type 300 (integer -1 100))
bd644055ef44 Correct a bug in #'check-type, non-setf'able PLACEs Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3934 "checking #'check-type errors properly on fixnum literal PLACE")
bd644055ef44 Correct a bug in #'check-type, non-setf'able PLACEs Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3935 (Assert (prog1 t (check-type (+ 100 200) fixnum))
bd644055ef44 Correct a bug in #'check-type, non-setf'able PLACEs Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3936 "checking #'check-type OK, non-setfable PLACE")
bd644055ef44 Correct a bug in #'check-type, non-setf'able PLACEs Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3937 (Check-Error wrong-type-argument
bd644055ef44 Correct a bug in #'check-type, non-setf'able PLACEs Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3938 (check-type (+ 600 1000) (integer 0 20))
bd644055ef44 Correct a bug in #'check-type, non-setf'able PLACEs Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3939 "checking #'check-type errors properly, non-setfable PLACE")
bd644055ef44 Correct a bug in #'check-type, non-setf'able PLACEs Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3940
4732 2491a837112c Fix typo in test of equalp and add more tests. Stephen J. Turnbull <stephen@xemacs.org> parents: 4728 diff changeset	3941 ;;; end of lisp-tests.el

Mercurial > hg > xemacs-beta

annotate tests/automated/lisp-tests.el @ 5915:1af53d35dd53