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

annotate tests/automated/lisp-tests.el @ 5891:a0e751d6c3ad

Import the #'clear-string API from GNU, use it in tls.c src/ChangeLog addition: 2015-04-18 Aidan Kehoe <kehoea@parhasard.net> * sequence.c (Fclear_string): New, API from GNU. Zero a string's contents, making sure the text is not kept around even when the string's data is reallocated because of a changed character length. * sequence.c (syms_of_sequence): Make it available to Lisp. * lisp.h: Make it available to C code. * tls.c (nss_pk11_password): Use it. * tls.c (gnutls_pk11_password): Use it. * tls.c (openssl_password): Use it. tests/ChangeLog addition: 2015-04-18 Aidan Kehoe <kehoea@parhasard.net> * automated/lisp-tests.el: Test #'clear-string, just added. Unfortunately there's no way to be certain from Lisp that the old password data has been erased after realloc; it may be worth adding a test to tests.c, but *we'll be reading memory we shouldn't be*, so that gives me pause.

author	Aidan Kehoe <kehoea@parhasard.net>
date	Sat, 18 Apr 2015 23:00:14 +0100
parents	c96000075e49
children	d3d073aceaea

rev	line source
5035 b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1 ;; Copyright (C) 1998 Free Software Foundation, Inc. -- coding: iso-8859-1 --
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2 ;; Copyright (C) 2010 Ben Wing.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	3
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	4 ;; Author: Martin Buchholz <martin@xemacs.org>
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	5 ;; Maintainer: Martin Buchholz <martin@xemacs.org>
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	6 ;; Created: 1998
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	7 ;; Keywords: tests
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	8
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	9 ;; This file is part of XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	10
5402 308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	11 ;; XEmacs is free software: you can redistribute it and/or modify it
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	12 ;; under the terms of the GNU General Public License as published by the
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	13 ;; Free Software Foundation, either version 3 of the License, or (at your
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	14 ;; option) any later version.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	15
5402 308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	16 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	17 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	18 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	19 ;; for more details.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	20
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	21 ;; You should have received a copy of the GNU General Public License
5402 308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5244 diff changeset	22 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	23
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	24 ;;; Synched up with: Not in FSF.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	25
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	26 ;;; Commentary:
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	27
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	28 ;;; Test basic Lisp engine functionality
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	29 ;;; See test-harness.el for instructions on how to run these tests.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	30
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	31 (eval-when-compile
5772 cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	32 ;; The labels below give trouble with a max-lisp-eval-depth of less than
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	33 ;; about 2000, work around that:
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	34 (setq max-lisp-eval-depth (max 2000 max-lisp-eval-depth))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	35 (condition-case nil
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	36 (require 'test-harness)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	37 (file-error
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	38 (push "." load-path)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	39 (when (and (boundp 'load-file-name) (stringp load-file-name))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	40 (push (file-name-directory load-file-name) load-path))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	41 (require 'test-harness))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	42
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	43 (Check-Error wrong-number-of-arguments (setq setq-test-foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	44 (Check-Error wrong-number-of-arguments (setq setq-test-foo 1 setq-test-bar))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	45 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	46 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo 1 setq-test-bar))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	47 (Assert (eq (setq) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	48 (Assert (eq (setq-default) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	49 (Assert (eq (setq setq-test-foo 42) 42))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	50 (Assert (eq (setq-default setq-test-foo 42) 42))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	51 (Assert (eq (setq setq-test-foo 42 setq-test-bar 99) 99))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	52 (Assert (eq (setq-default setq-test-foo 42 setq-test-bar 99) 99))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	53
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	54 (macrolet ((test-setq (expected-result &rest body)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	55 `(progn
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	56 (defun test-setq-fun () ,@body)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	57 (Assert (eq ,expected-result (test-setq-fun)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	58 (byte-compile 'test-setq-fun)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	59 (Assert (eq ,expected-result (test-setq-fun))))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	60 (test-setq nil (setq))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	61 (test-setq nil (setq-default))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	62 (test-setq 42 (setq test-setq-var 42))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	63 (test-setq 42 (setq-default test-setq-var 42))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	64 (test-setq 42 (setq test-setq-bar 99 test-setq-var 42))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	65 (test-setq 42 (setq-default test-setq-bar 99 test-setq-var 42))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	66 )
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	67
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	68 (let ((my-vector [1 2 3 4])
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	69 (my-bit-vector (bit-vector 1 0 1 0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	70 (my-string "1234")
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	71 (my-list '(1 2 3 4)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	72
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	73 ;;(Assert (fooooo)) ;; Generate Other failure
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	74 ;;(Assert (eq 1 2)) ;; Generate Assertion failure
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	75
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	76 (dolist (sequence (list my-vector my-bit-vector my-string my-list))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	77 (Assert (sequencep sequence))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	78 (Assert (eq 4 (length sequence))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	79
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	80 (dolist (array (list my-vector my-bit-vector my-string))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	81 (Assert (arrayp array)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	82
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	83 (Assert (eq (elt my-vector 0) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	84 (Assert (eq (elt my-bit-vector 0) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	85 (Assert (eq (elt my-string 0) ?1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	86 (Assert (eq (elt my-list 0) 1))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	87
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	88 (fillarray my-vector 5)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	89 (fillarray my-bit-vector 1)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	90 (fillarray my-string ?5)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	91
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	92 (dolist (array (list my-vector my-bit-vector))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	93 (Assert (eq 4 (length array))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	94
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	95 (Assert (eq (elt my-vector 0) 5))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	96 (Assert (eq (elt my-bit-vector 0) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	97 (Assert (eq (elt my-string 0) ?5))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	98
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	99 (Assert (eq (elt my-vector 3) 5))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	100 (Assert (eq (elt my-bit-vector 3) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	101 (Assert (eq (elt my-string 3) ?5))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	102
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	103 (fillarray my-bit-vector 0)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	104 (Assert (eq 4 (length my-bit-vector)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	105 (Assert (eq (elt my-bit-vector 2) 0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	106 )
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	107
5772 cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	108 (defun make-circular-list (length &optional value)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	109 "Create evil emacs-crashing circular list of length LENGTH.
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	110
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	111 Optional VALUE is the value to go into the cars. If nil, some non-nil value
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	112 will be used to make debugging easier."
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	113 (let ((circular-list
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	114 (make-list
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	115 length
5772 cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	116 (or value
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	117 'you-are-trapped-in-a-twisty-maze-of-cons-cells-all-alike))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	118 (setcdr (last circular-list) circular-list)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	119 circular-list))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	120
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	121 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	122 ;; Test `nconc'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	123 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	124 (defun make-list-012 () (list 0 1 2))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	125
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	126 (Check-Error wrong-type-argument (nconc 'foo nil))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	127
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	128 (dolist (length '(1 2 3 4 1000 2000))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	129 (Check-Error circular-list (nconc (make-circular-list length) 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	130 (Check-Error circular-list (nconc '(1 . 2) (make-circular-list length) 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	131 (Check-Error circular-list (nconc '(1 . 2) '(3 . 4) (make-circular-list length) 'foo)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	132
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	133 (Assert (eq (nconc) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	134 (Assert (eq (nconc nil) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	135 (Assert (eq (nconc nil nil) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	136 (Assert (eq (nconc nil nil nil) nil))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	137
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	138 (let ((x (make-list-012))) (Assert (eq (nconc nil x) x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	139 (let ((x (make-list-012))) (Assert (eq (nconc x nil) x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	140 (let ((x (make-list-012))) (Assert (eq (nconc nil x nil) x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	141 (let ((x (make-list-012))) (Assert (eq (nconc x) x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	142 (let ((x (make-list-012))) (Assert (eq (nconc x (make-circular-list 3)) x)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	143
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	144 (Assert (equal (nconc '(1 . 2) '(3 . 4) '(5 . 6)) '(1 3 5 . 6)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	145
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	146 (let ((y (nconc (make-list-012) nil (list 3 4 5) nil)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	147 (Assert (eq (length y) 6))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	148 (Assert (eq (nth 3 y) 3)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	149
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	150 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	151 ;; Test `last'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	152 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	153 (Check-Error wrong-type-argument (last 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	154 (Check-Error wrong-number-of-arguments (last))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	155 (Check-Error wrong-number-of-arguments (last '(1 2) 1 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	156 (Check-Error circular-list (last (make-circular-list 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	157 (Check-Error circular-list (last (make-circular-list 2000)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	158 (let ((x (list 0 1 2 3)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	159 (Assert (eq (last nil) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	160 (Assert (eq (last x 0) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	161 (Assert (eq (last x ) (cdddr x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	162 (Assert (eq (last x 1) (cdddr x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	163 (Assert (eq (last x 2) (cddr x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	164 (Assert (eq (last x 3) (cdr x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	165 (Assert (eq (last x 4) x))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	166 (Assert (eq (last x 9) x))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	167 (Assert (eq (last '(1 . 2) 0) 2))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	168 )
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	169
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	170 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	171 ;; Test `butlast' and `nbutlast'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	172 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	173 (Check-Error wrong-type-argument (butlast 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	174 (Check-Error wrong-type-argument (nbutlast 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	175 (Check-Error wrong-number-of-arguments (butlast))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	176 (Check-Error wrong-number-of-arguments (nbutlast))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	177 (Check-Error wrong-number-of-arguments (butlast '(1 2) 1 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	178 (Check-Error wrong-number-of-arguments (nbutlast '(1 2) 1 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	179 (Check-Error circular-list (butlast (make-circular-list 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	180 (Check-Error circular-list (nbutlast (make-circular-list 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	181 (Check-Error circular-list (butlast (make-circular-list 2000)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	182 (Check-Error circular-list (nbutlast (make-circular-list 2000)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	183
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	184 (let* ((x (list 0 1 2 3))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	185 (y (butlast x))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	186 (z (nbutlast x)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	187 (Assert (eq z x))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	188 (Assert (not (eq y x)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	189 (Assert (equal y '(0 1 2)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	190 (Assert (equal z y)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	191
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	192 (let* ((x (list 0 1 2 3 4))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	193 (y (butlast x 2))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	194 (z (nbutlast x 2)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	195 (Assert (eq z x))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	196 (Assert (not (eq y x)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	197 (Assert (equal y '(0 1 2)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	198 (Assert (equal z y)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	199
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	200 (let* ((x (list 0 1 2 3))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	201 (y (butlast x 0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	202 (z (nbutlast x 0)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	203 (Assert (eq z x))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	204 (Assert (not (eq y x)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	205 (Assert (equal y '(0 1 2 3)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	206 (Assert (equal z y)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	207
5285 99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	208 (let* ((x (list* 0 1 2 3 4 5 6.0 ?7 ?8 (vector 'a 'b 'c)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	209 (y (butlast x 0))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	210 (z (nbutlast x 0)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	211 (Assert (eq z x))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	212 (Assert (not (eq y x)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	213 (Assert (equal y '(0 1 2 3 4 5 6.0 ?7 ?8)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	214 (Assert (equal z y)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	215
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	216 (Assert (eq (butlast '(x)) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	217 (Assert (eq (nbutlast '(x)) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	218 (Assert (eq (butlast '()) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	219 (Assert (eq (nbutlast '()) nil))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	220
5307 c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	221 (when (featurep 'bignum)
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	222 (let* ((x (list* 0 1 2 3 4 5 6.0 ?7 ?8 (vector 'a 'b 'c)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	223 (y (butlast x (* 2 most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	224 (z (nbutlast x (* 3 most-positive-fixnum))))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	225 (Assert (eq nil y) "checking butlast with a large bignum gives nil")
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	226 (Assert (eq nil z) "checking nbutlast with a large bignum gives nil")
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	227 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	228 (nbutlast x (1- most-negative-fixnum))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	229 "checking nbutlast with a negative bignum errors")))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	230
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	231 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	232 ;; Test `copy-list'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	233 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	234 (Check-Error wrong-type-argument (copy-list 'foo))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	235 (Check-Error wrong-number-of-arguments (copy-list))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	236 (Check-Error wrong-number-of-arguments (copy-list '(1 2) 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	237 (Check-Error circular-list (copy-list (make-circular-list 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	238 (Check-Error circular-list (copy-list (make-circular-list 2000)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	239 (Assert (eq '() (copy-list '())))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	240 (dolist (x '((1) (1 2) (1 2 3) (1 2 . 3)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	241 (let ((y (copy-list x)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	242 (Assert (and (equal x y) (not (eq x y))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	243
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	244 ;;-----------------------------------------------------
5285 99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	245 ;; Test `ldiff'
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	246 ;;-----------------------------------------------------
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	247 (Check-Error wrong-type-argument (ldiff 'foo pi))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	248 (Check-Error wrong-number-of-arguments (ldiff))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	249 (Check-Error wrong-number-of-arguments (ldiff '(1 2)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	250 (Check-Error circular-list (ldiff (make-circular-list 1) nil))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	251 (Check-Error circular-list (ldiff (make-circular-list 2000) nil))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	252 (Assert (eq '() (ldiff '() pi)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	253 (dolist (x '((1) (1 2) (1 2 3) (1 2 . 3)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	254 (let ((y (ldiff x nil)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	255 (Assert (and (equal x y) (not (eq x y))))))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	256
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	257 (let* ((vector (vector 'foo))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	258 (dotted `(1 2 3 ,pi 40 50 . ,vector))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	259 (dotted-pi `(1 2 3 . ,pi))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	260 without-vector without-pi)
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	261 (Assert (equal dotted (ldiff dotted nil))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	262 "checking ldiff handles dotted lists properly")
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	263 (Assert (equal (butlast dotted 0) (ldiff dotted vector))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	264 "checking ldiff discards dotted elements correctly")
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	265 (Assert (equal (butlast dotted-pi 0) (ldiff dotted-pi (* 4 (atan 1))))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	266 "checking ldiff handles float equivalence correctly"))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	267
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	268 ;;-----------------------------------------------------
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	269 ;; Test `tailp'
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	270 ;;-----------------------------------------------------
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	271 (Check-Error wrong-type-argument (tailp pi 'foo))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	272 (Check-Error wrong-number-of-arguments (tailp))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	273 (Check-Error wrong-number-of-arguments (tailp '(1 2)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	274 (Check-Error circular-list (tailp nil (make-circular-list 1)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	275 (Check-Error circular-list (tailp nil (make-circular-list 2000)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	276 (Assert (null (tailp pi '()))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	277 "checking pi is not a tail of the list nil")
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	278 (Assert (tailp 3 '(1 2 . 3))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	279 "checking #'tailp works with a dotted integer.")
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	280 (Assert (tailp pi `(1 2 . ,(* 4 (atan 1))))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	281 "checking tailp works with non-eq dotted floats.")
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	282 (let ((list (make-list 2048 nil)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	283 (Assert (tailp (nthcdr 2000 list) (nconc list list))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	284 "checking #'tailp succeeds with circular LIST containing SUBLIST"))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	285
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	286 ;;-----------------------------------------------------
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	287 ;; Test `endp'
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	288 ;;-----------------------------------------------------
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	289 (Check-Error wrong-type-argument (endp 'foo))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	290 (Check-Error wrong-number-of-arguments (endp))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	291 (Check-Error wrong-number-of-arguments (endp '(1 2) 'foo))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	292 (Assert (endp nil) "checking nil is recognized as the end of a list")
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	293 (Assert (not (endp (list 200 200 4 0 9)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	294 "checking a cons is not recognised as the end of a list")
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	295
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5283 diff changeset	296 ;;-----------------------------------------------------
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	297 ;; Arithmetic operations
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	298 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	299
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	300 ;; Test `+'
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	301 (Assert (eq (+ 1 1) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	302 (Assert (= (+ 1.0 1.0) 2.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	303 (Assert (= (+ 1.0 3.0 0.0) 4.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	304 (Assert (= (+ 1 1.0) 2.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	305 (Assert (= (+ 1.0 1) 2.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	306 (Assert (= (+ 1.0 1 1) 3.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	307 (Assert (= (+ 1 1 1.0) 3.0))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	308 (if (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	309 (progn
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	310 (Assert (bignump (1+ most-positive-fixnum)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	311 (Assert (eq most-positive-fixnum (1- (1+ most-positive-fixnum))))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	312 (Assert (bignump (+ most-positive-fixnum 1)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	313 (Assert (eq most-positive-fixnum (- (+ most-positive-fixnum 1) 1)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	314 (Assert (= (1+ most-positive-fixnum) (- most-negative-fixnum)))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	315 (Assert (zerop (+ (* 3 most-negative-fixnum) (* 3 most-positive-fixnum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	316 3))))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	317 (Assert (eq (1+ most-positive-fixnum) most-negative-fixnum))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	318 (Assert (eq (+ most-positive-fixnum 1) most-negative-fixnum)))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	319
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	320 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	321 (let ((threefourths (read "3/4"))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	322 (threehalfs (read "3/2"))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	323 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	324 (bigneg (div (+ most-positive-fixnum 2) most-negative-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	325 (negone (div (1+ most-positive-fixnum) most-negative-fixnum)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	326 (Assert (= negone -1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	327 (Assert (= threehalfs (+ threefourths threefourths)))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	328 (Assert (zerop (+ bigpos bigneg)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	329
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	330 ;; Test `-'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	331 (Check-Error wrong-number-of-arguments (-))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	332 (Assert (eq (- 0) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	333 (Assert (eq (- 1) -1))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	334 (dolist (one `(1 1.0 ?\1 ,(Int-to-Marker 1)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	335 (Assert (= (+ 1 one) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	336 (Assert (= (+ one) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	337 (Assert (= (+ one) one))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	338 (Assert (= (- one) -1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	339 (Assert (= (- one one) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	340 (Assert (= (- one one one) -1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	341 (Assert (= (- 0 one) -1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	342 (Assert (= (- 0 one one) -2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	343 (Assert (= (+ one 1) 2))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	344 (dolist (zero '(0 0.0 ?\0))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	345 (Assert (= (+ 1 zero) 1) zero)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	346 (Assert (= (+ zero 1) 1) zero)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	347 (Assert (= (- zero) zero) zero)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	348 (Assert (= (- zero) 0) zero)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	349 (Assert (= (- zero zero) 0) zero)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	350 (Assert (= (- zero one one) -2) zero)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	351
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	352 (Assert (= (- 1.5 1) .5))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	353 (Assert (= (- 1 1.5) (- .5)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	354
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	355 (if (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	356 (progn
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	357 (Assert (bignump (1- most-negative-fixnum)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	358 (Assert (eq most-negative-fixnum (1+ (1- most-negative-fixnum))))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	359 (Assert (bignump (- most-negative-fixnum 1)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	360 (Assert (eq most-negative-fixnum (+ (- most-negative-fixnum 1) 1)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	361 (Assert (= (1- most-negative-fixnum) (- 0 most-positive-fixnum 2)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	362 (Assert (eq (- (- most-positive-fixnum most-negative-fixnum)
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	363 (* 2 most-positive-fixnum))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	364 1)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	365 (Assert (eq (1- most-negative-fixnum) most-positive-fixnum))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	366 (Assert (eq (- most-negative-fixnum 1) most-positive-fixnum)))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	367
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	368 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	369 (let ((threefourths (read "3/4"))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	370 (threehalfs (read "3/2"))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	371 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	372 (bigneg (div most-positive-fixnum most-negative-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	373 (negone (div (1+ most-positive-fixnum) most-negative-fixnum)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	374 (Assert (= (- negone) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	375 (Assert (= threefourths (- threehalfs threefourths)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	376 (Assert (= (- bigpos bigneg) 2))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	377
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	378 ;; Test `/'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	379
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	380 ;; Test division by zero errors
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	381 (dolist (zero '(0 0.0 ?\0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	382 (Check-Error arith-error (/ zero))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	383 (dolist (n1 `(42 42.0 ?\042 ,(Int-to-Marker 42)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	384 (Check-Error arith-error (/ n1 zero))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	385 (dolist (n2 `(3 3.0 ?\03 ,(Int-to-Marker 3)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	386 (Check-Error arith-error (/ n1 n2 zero)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	387
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	388 ;; Other tests for `/'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	389 (Check-Error wrong-number-of-arguments (/))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	390 (let (x)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	391 (Assert (= (/ (setq x 2)) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	392 (Assert (= (/ (setq x 2.0)) 0.5)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	393
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	394 (dolist (six '(6 6.0 ?\06))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	395 (dolist (two '(2 2.0 ?\02))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	396 (dolist (three '(3 3.0 ?\03))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	397 (Assert (= (/ six two) three) (list six two three)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	398
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	399 (dolist (three '(3 3.0 ?\03))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	400 (Assert (= (/ three 2.0) 1.5) three))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	401 (dolist (two '(2 2.0 ?\02))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	402 (Assert (= (/ 3.0 two) 1.5) two))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	403
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	404 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	405 (let* ((million 1000000)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	406 (billion (* million 1000)) ;; American, not British, billion
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	407 (trillion (* billion 1000)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	408 (Assert (= (/ billion 1000) (/ trillion million) million 1000000.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	409 (Assert (= (/ billion -1000) (/ trillion (- million)) (- million)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	410 (Assert (= (/ trillion 1000) billion 1000000000.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	411 (Assert (= (/ trillion -1000) (- billion) -1000000000.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	412 (Assert (= (/ trillion 10) (* 100 billion) 100000000000.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	413 (Assert (= (/ (- trillion) 10) (* -100 billion) -100000000000.0))))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	414
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	415 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	416 (let ((half (div 1 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	417 (fivefourths (div 5 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	418 (fivehalfs (div 5 2)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	419 (Assert (= half (read "3000000000/6000000000")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	420 (Assert (= (/ fivehalfs fivefourths) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	421 (Assert (= (/ fivefourths fivehalfs) half))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	422 (Assert (= (- half) (read "-3000000000/6000000000")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	423 (Assert (= (/ fivehalfs (- fivefourths)) -2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	424 (Assert (= (/ (- fivefourths) fivehalfs) (- half)))))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	425
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	426 ;; Test `*'
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	427 (Assert (= 1 (*)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	428
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	429 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	430 (Assert (= 1 (* one)) one))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	431
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	432 (dolist (two '(2 2.0 ?\02))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	433 (Assert (= 2 (* two)) two))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	434
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	435 (dolist (six '(6 6.0 ?\06))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	436 (dolist (two '(2 2.0 ?\02))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	437 (dolist (three '(3 3.0 ?\03))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	438 (Assert (= (* three two) six) (list three two six)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	439
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	440 (dolist (three '(3 3.0 ?\03))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	441 (dolist (two '(2 2.0 ?\02))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	442 (Assert (= (* 1.5 two) three) (list two three))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	443 (dolist (five '(5 5.0 ?\05))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	444 (Assert (= 30 (* five two three)) (list five two three)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	445
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	446 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	447 (let ((64K 65536))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	448 (Assert (= (* 64K 64K) (read "4294967296")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	449 (Assert (= (* (- 64K) 64K) (read "-4294967296")))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	450 (Assert (/= (* -1 most-negative-fixnum) most-negative-fixnum))))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	451
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	452 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	453 (let ((half (div 1 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	454 (fivefourths (div 5 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	455 (twofifths (div 2 5)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	456 (Assert (= (* fivefourths twofifths) half))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	457 (Assert (= (* half twofifths) (read "3/15")))))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	458
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	459 ;; Test `+'
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	460 (Assert (= 0 (+)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	461
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	462 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	463 (Assert (= 1 (+ one)) one))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	464
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	465 (dolist (two '(2 2.0 ?\02))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	466 (Assert (= 2 (+ two)) two))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	467
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	468 (dolist (five '(5 5.0 ?\05))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	469 (dolist (two '(2 2.0 ?\02))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	470 (dolist (three '(3 3.0 ?\03))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	471 (Assert (= (+ three two) five) (list three two five))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	472 (Assert (= 10 (+ five two three)) (list five two three)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	473
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	474 ;; Test `max', `min'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	475 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	476 (Assert (= one (max one)) one)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	477 (Assert (= one (max one one)) one)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	478 (Assert (= one (max one one one)) one)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	479 (Assert (= one (min one)) one)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	480 (Assert (= one (min one one)) one)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	481 (Assert (= one (min one one one)) one)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	482 (dolist (two `(2 2.0 ?\02 ,(Int-to-Marker 2)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	483 (Assert (= one (min one two)) (list one two))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	484 (Assert (= one (min one two two)) (list one two))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	485 (Assert (= one (min two two one)) (list one two))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	486 (Assert (= two (max one two)) (list one two))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	487 (Assert (= two (max one two two)) (list one two))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	488 (Assert (= two (max two two one)) (list one two))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	489
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	490 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	491 (let ((big (1+ most-positive-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	492 (small (1- most-negative-fixnum)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	493 (Assert (= big (max 1 1000000.0 most-positive-fixnum big)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	494 (Assert (= small (min -1 -1000000.0 most-negative-fixnum small)))))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	495
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	496 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	497 (let* ((big (1+ most-positive-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	498 (small (1- most-negative-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	499 (bigr (div (* 5 (1+ most-positive-fixnum)) 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	500 (smallr (- bigr)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	501 (Assert (= bigr (max 1 1000000.0 most-positive-fixnum big bigr)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	502 (Assert (= smallr (min -1 -1000000.0 most-negative-fixnum small smallr)))))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	503
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	504 ;; The byte compiler has special handling for these constructs:
1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	505 (let ((three 3) (five 5))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	506 (Assert (= (+ three five 1) 9))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	507 (Assert (= (+ 1 three five) 9))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	508 (Assert (= (+ three five -1) 7))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	509 (Assert (= (+ -1 three five) 7))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	510 (Assert (= (+ three 1) 4))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	511 (Assert (= (+ three -1) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	512 (Assert (= (+ -1 three) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	513 (Assert (= (+ -1 three) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	514 (Assert (= (- three five 1) -3))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	515 (Assert (= (- 1 three five) -7))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	516 (Assert (= (- three five -1) -1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	517 (Assert (= (- -1 three five) -9))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	518 (Assert (= (- three 1) 2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	519 (Assert (= (- three 2 1) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	520 (Assert (= (- 2 three 1) -2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	521 (Assert (= (- three -1) 4))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	522 (Assert (= (- three 0) 3))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	523 (Assert (= (- three 0 five) -2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	524 (Assert (= (- 0 three 0 five) -8))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	525 (Assert (= (- 0 three five) -8))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	526 (Assert (= (* three 2) 6))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	527 (Assert (= (* three -1 five) -15))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	528 (Assert (= (* three 1 five) 15))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	529 (Assert (= (* three 0 five) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	530 (Assert (= (* three 2 five) 30))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	531 (Assert (= (/ three 1) 3))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	532 (Assert (= (/ three -1) -3))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	533 (Assert (= (/ (* five five) 2 2) 6))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	534 (Assert (= (/ 64 five 2) 6)))
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	535
1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	536
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	537 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	538 ;; Logical bit-twiddling operations
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	539 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	540 (Assert (= (logxor) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	541 (Assert (= (logior) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	542 (Assert (= (logand) -1))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	543
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	544 (Check-Error wrong-type-argument (logxor 3.0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	545 (Check-Error wrong-type-argument (logior 3.0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	546 (Check-Error wrong-type-argument (logand 3.0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	547
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	548 (dolist (three '(3 ?\03))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	549 (Assert (eq 3 (logand three)) three)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	550 (Assert (eq 3 (logxor three)) three)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	551 (Assert (eq 3 (logior three)) three)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	552 (Assert (eq 3 (logand three three)) three)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	553 (Assert (eq 0 (logxor three three)) three)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	554 (Assert (eq 3 (logior three three))) three)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	555
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	556 (dolist (one `(1 ?\01 ,(Int-to-Marker 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	557 (dolist (two '(2 ?\02))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	558 (Assert (eq 0 (logand one two)) (list one two))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	559 (Assert (eq 3 (logior one two)) (list one two))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	560 (Assert (eq 3 (logxor one two)) (list one two)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	561 (dolist (three '(3 ?\03))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	562 (Assert (eq 1 (logand one three)) (list one three))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	563 (Assert (eq 3 (logior one three)) (list one three))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	564 (Assert (eq 2 (logxor one three)) (list one three))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	565
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	566 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	567 ;; Test `%', mod
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	568 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	569 (Check-Error wrong-number-of-arguments (%))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	570 (Check-Error wrong-number-of-arguments (% 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	571 (Check-Error wrong-number-of-arguments (% 1 2 3))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	572
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	573 (Check-Error wrong-number-of-arguments (mod))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	574 (Check-Error wrong-number-of-arguments (mod 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	575 (Check-Error wrong-number-of-arguments (mod 1 2 3))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	576
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	577 (Check-Error wrong-type-argument (% 10.0 2))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	578 (Check-Error wrong-type-argument (% 10 2.0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	579
5576 071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	580 (labels ((test1 (x) (Assert (eql x (+ (% x 17) (* (/ x 17) 17))) x))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	581 (test2 (x) (Assert (eql (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17))) x))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	582 (test3 (x) (Assert (eql x (+ (% (- x) 17) (* (/ (- x) 17) 17))) x))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	583 (test4 (x) (Assert (eql (% x -17) (- (% (- x) 17))) x))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	584 (test5 (x) (Assert (eql (% x -17) (% (- x) 17))) x))
2056 ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	585 (test1 most-negative-fixnum)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	586 (if (featurep 'bignum)
2075 c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james] james parents: 2056 diff changeset	587 (progn
c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james] james parents: 2056 diff changeset	588 (test2 most-negative-fixnum)
c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james] james parents: 2056 diff changeset	589 (test4 most-negative-fixnum))
c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james] james parents: 2056 diff changeset	590 (test3 most-negative-fixnum)
c0dad8c0e80d [xemacs-hg @ 2004-05-13 15:33:15 by james] james parents: 2056 diff changeset	591 (test5 most-negative-fixnum))
2056 ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	592 (test1 most-positive-fixnum)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	593 (test2 most-positive-fixnum)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	594 (test4 most-positive-fixnum)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	595 (dotimes (j 30)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	596 (let ((x (random)))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	597 (if (eq x most-negative-fixnum) (setq x (1+ x)))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	598 (if (eq x most-positive-fixnum) (setq x (1- x)))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	599 (test1 x)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	600 (test2 x)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	601 (test4 x))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	602
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	603 (macrolet
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	604 ((division-test (seven)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	605 `(progn
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	606 (Assert (eq (% ,seven 2) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	607 (Assert (eq (% ,seven -2) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	608 (Assert (eq (% (- ,seven) 2) -1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	609 (Assert (eq (% (- ,seven) -2) -1))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	610
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	611 (Assert (eq (% ,seven 4) 3))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	612 (Assert (eq (% ,seven -4) 3))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	613 (Assert (eq (% (- ,seven) 4) -3))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	614 (Assert (eq (% (- ,seven) -4) -3))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	615
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	616 (Assert (eq (% 35 ,seven) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	617 (Assert (eq (% -35 ,seven) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	618 (Assert (eq (% 35 (- ,seven)) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	619 (Assert (eq (% -35 (- ,seven)) 0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	620
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	621 (Assert (eq (mod ,seven 2) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	622 (Assert (eq (mod ,seven -2) -1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	623 (Assert (eq (mod (- ,seven) 2) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	624 (Assert (eq (mod (- ,seven) -2) -1))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	625
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	626 (Assert (eq (mod ,seven 4) 3))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	627 (Assert (eq (mod ,seven -4) -1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	628 (Assert (eq (mod (- ,seven) 4) 1))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	629 (Assert (eq (mod (- ,seven) -4) -3))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	630
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	631 (Assert (eq (mod 35 ,seven) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	632 (Assert (eq (mod -35 ,seven) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	633 (Assert (eq (mod 35 (- ,seven)) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	634 (Assert (eq (mod -35 (- ,seven)) 0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	635
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	636 (Assert (= (mod ,seven 2.0) 1.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	637 (Assert (= (mod ,seven -2.0) -1.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	638 (Assert (= (mod (- ,seven) 2.0) 1.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	639 (Assert (= (mod (- ,seven) -2.0) -1.0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	640
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	641 (Assert (= (mod ,seven 4.0) 3.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	642 (Assert (= (mod ,seven -4.0) -1.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	643 (Assert (= (mod (- ,seven) 4.0) 1.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	644 (Assert (= (mod (- ,seven) -4.0) -3.0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	645
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	646 (Assert (eq (% 0 ,seven) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	647 (Assert (eq (% 0 (- ,seven)) 0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	648
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	649 (Assert (eq (mod 0 ,seven) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	650 (Assert (eq (mod 0 (- ,seven)) 0))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	651
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	652 (Assert (= (mod 0.0 ,seven) 0.0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	653 (Assert (= (mod 0.0 (- ,seven)) 0.0)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	654
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	655 (division-test 7)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	656 (division-test ?\07)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	657 (division-test (Int-to-Marker 7)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	658
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	659 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	660 (let ((big (+ (* 7 most-positive-fixnum 6)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	661 (negbig (- (* 7 most-negative-fixnum 6))))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	662 (= (% big (1+ most-positive-fixnum)) most-positive-fixnum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	663 (= (% negbig (1- most-negative-fixnum)) most-negative-fixnum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	664 (= (mod big (1+ most-positive-fixnum)) most-positive-fixnum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	665 (= (mod negbig (1- most-negative-fixnum)) most-negative-fixnum)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	666
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	667 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	668 ;; Arithmetic comparison operations
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	669 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	670 (Check-Error wrong-number-of-arguments (=))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	671 (Check-Error wrong-number-of-arguments (<))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	672 (Check-Error wrong-number-of-arguments (>))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	673 (Check-Error wrong-number-of-arguments (<=))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	674 (Check-Error wrong-number-of-arguments (>=))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	675 (Check-Error wrong-number-of-arguments (/=))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	676
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	677 ;; One argument always yields t
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	678 (loop for x in `(1 1.0 ,(Int-to-Marker 1) ?z) do
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	679 (Assert (eq t (= x)) x)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	680 (Assert (eq t (< x)) x)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	681 (Assert (eq t (> x)) x)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	682 (Assert (eq t (>= x)) x)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	683 (Assert (eq t (<= x)) x)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	684 (Assert (eq t (/= x)) x)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	685 )
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	686
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	687 ;; Type checking
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	688 (Check-Error wrong-type-argument (= 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	689 (Check-Error wrong-type-argument (<= 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	690 (Check-Error wrong-type-argument (>= 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	691 (Check-Error wrong-type-argument (< 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	692 (Check-Error wrong-type-argument (> 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	693 (Check-Error wrong-type-argument (/= 'foo 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	694
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	695 ;; Meat
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	696 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	697 (dolist (two '(2 2.0 ?\02))
2056 ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	698 (Assert (< one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	699 (Assert (<= one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	700 (Assert (<= two two) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	701 (Assert (> two one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	702 (Assert (>= two one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	703 (Assert (>= two two) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	704 (Assert (/= one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	705 (Assert (not (/= two two)) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	706 (Assert (not (< one one)) one)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	707 (Assert (not (> one one)) one)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	708 (Assert (<= one one two two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	709 (Assert (not (< one one two two)) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	710 (Assert (>= two two one one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	711 (Assert (not (> two two one one)) (list one two))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	712 (Assert (= one one one) one)
2056 ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	713 (Assert (not (= one one one two)) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	714 (Assert (not (/= one two one)) (list one two))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	715 ))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	716
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	717 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	718 (dolist (two '(2 2.0 ?\02))
2056 ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	719 (Assert (< one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	720 (Assert (<= one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	721 (Assert (<= two two) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	722 (Assert (> two one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	723 (Assert (>= two one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	724 (Assert (>= two two) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	725 (Assert (/= one two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	726 (Assert (not (/= two two)) two)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	727 (Assert (not (< one one)) one)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	728 (Assert (not (> one one)) one)
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	729 (Assert (<= one one two two) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	730 (Assert (not (< one one two two)) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	731 (Assert (>= two two one one) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	732 (Assert (not (> two two one one)) (list one two))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	733 (Assert (= one one one) one)
2056 ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	734 (Assert (not (= one one one two)) (list one two))
ab71063baf27 [xemacs-hg @ 2004-05-03 15:08:41 by james] james parents: 1983 diff changeset	735 (Assert (not (/= one two one)) (list one two))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	736 ))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	737
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	738 ;; ad-hoc
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	739 (Assert (< 1 2))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	740 (Assert (< 1 2 3 4 5 6))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	741 (Assert (not (< 1 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	742 (Assert (not (< 2 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	743
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	744
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	745 (Assert (not (< 1 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	746 (Assert (< 1 2 3 4 5 6))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	747 (Assert (<= 1 2 3 4 5 6))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	748 (Assert (<= 1 2 3 4 5 6 6))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	749 (Assert (not (< 1 2 3 4 5 6 6)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	750 (Assert (<= 1 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	751
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	752 (Assert (not (eq (point) (point-marker))))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	753 (Assert (= 1 (Int-to-Marker 1)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	754 (Assert (= (point) (point-marker)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	755
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	756 (when (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	757 (let ((big1 (1+ most-positive-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	758 (big2 (* 10 most-positive-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	759 (small1 (1- most-negative-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	760 (small2 (* 10 most-negative-fixnum)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	761 (Assert (< small2 small1 most-negative-fixnum most-positive-fixnum big1
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	762 big2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	763 (Assert (<= small2 small1 most-negative-fixnum most-positive-fixnum big1
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	764 big2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	765 (Assert (> big2 big1 most-positive-fixnum most-negative-fixnum small1
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	766 small2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	767 (Assert (>= big2 big1 most-positive-fixnum most-negative-fixnum small1
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	768 small2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	769 (Assert (/= small2 small1 most-negative-fixnum most-positive-fixnum big1
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	770 big2))))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	771
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	772 (when (featurep 'ratio)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	773 (let ((big1 (div (* 10 most-positive-fixnum) 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	774 (big2 (div (* 5 most-positive-fixnum) 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	775 (big3 (div (* 7 most-positive-fixnum) 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	776 (small1 (div (* 10 most-negative-fixnum) 4))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	777 (small2 (div (* 5 most-negative-fixnum) 2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	778 (small3 (div (* 7 most-negative-fixnum) 2)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	779 (Assert (= big1 big2))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	780 (Assert (= small1 small2))
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	781 (Assert (< small3 small1 most-negative-fixnum most-positive-fixnum big1
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	782 big3))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	783 (Assert (<= small3 small2 small1 most-negative-fixnum most-positive-fixnum
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	784 big1 big2 big3))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	785 (Assert (> big3 big1 most-positive-fixnum most-negative-fixnum small1
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	786 small3))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	787 (Assert (>= big3 big2 big1 most-positive-fixnum most-negative-fixnum
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	788 small1 small2 small3))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	789 (Assert (/= big3 big1 most-positive-fixnum most-negative-fixnum small1
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	790 small3))))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	791
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	792 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	793 ;; testing list-walker functions
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	794 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	795 (macrolet
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	796 ((test-fun
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	797 (fun)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	798 `(progn
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	799 (Check-Error wrong-number-of-arguments (,fun))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	800 (Check-Error wrong-number-of-arguments (,fun nil))
5346 b4ef3128160c Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq. Aidan Kehoe <kehoea@parhasard.net> parents: 5339 diff changeset	801 (Check-Error (malformed-list wrong-type-argument) (,fun nil 1))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	802 ,@(loop for n in '(1 2 2000)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	803 collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n))))))
5374 d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	804 (test-funs (&rest funs) `(progn ,@(loop for fun in funs collect `(test-fun ,fun))))
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	805 (test-old-funs (&rest funs)
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	806 `(when (and (fboundp 'old-eq) (subrp (symbol-function 'old-eq)))
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	807 ,@(loop for fun in funs collect `(test-fun ,fun)))))
5346 b4ef3128160c Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq. Aidan Kehoe <kehoea@parhasard.net> parents: 5339 diff changeset	808 (test-funs member* member memq
b4ef3128160c Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq. Aidan Kehoe <kehoea@parhasard.net> parents: 5339 diff changeset	809 assoc* assoc assq
b4ef3128160c Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq. Aidan Kehoe <kehoea@parhasard.net> parents: 5339 diff changeset	810 rassoc* rassoc rassq
b4ef3128160c Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq. Aidan Kehoe <kehoea@parhasard.net> parents: 5339 diff changeset	811 delete* delete delq
b4ef3128160c Fix some testsuite failures, #'delete, #'delq, #'remove, #'remq. Aidan Kehoe <kehoea@parhasard.net> parents: 5339 diff changeset	812 remove* remove remq
5374 d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	813 remassoc remassq remrassoc remrassq)
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	814 (test-old-funs old-member old-memq old-assoc old-assq old-rassoc old-rassq
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	815 old-delete old-delq))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	816
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	817 (let ((x '((1 . 2) 3 (4 . 5))))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	818 (Assert (eq (assoc 1 x) (car x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	819 (Assert (eq (assq 1 x) (car x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	820 (Assert (eq (rassoc 1 x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	821 (Assert (eq (rassq 1 x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	822 (Assert (eq (assoc 2 x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	823 (Assert (eq (assq 2 x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	824 (Assert (eq (rassoc 2 x) (car x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	825 (Assert (eq (rassq 2 x) (car x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	826 (Assert (eq (assoc 3 x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	827 (Assert (eq (assq 3 x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	828 (Assert (eq (rassoc 3 x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	829 (Assert (eq (rassq 3 x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	830 (Assert (eq (assoc 4 x) (caddr x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	831 (Assert (eq (assq 4 x) (caddr x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	832 (Assert (eq (rassoc 4 x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	833 (Assert (eq (rassq 4 x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	834 (Assert (eq (assoc 5 x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	835 (Assert (eq (assq 5 x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	836 (Assert (eq (rassoc 5 x) (caddr x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	837 (Assert (eq (rassq 5 x) (caddr x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	838 (Assert (eq (assoc 6 x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	839 (Assert (eq (assq 6 x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	840 (Assert (eq (rassoc 6 x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	841 (Assert (eq (rassq 6 x) nil)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	842
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	843 (let ((x '(("1" . "2") "3" ("4" . "5"))))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	844 (Assert (eq (assoc "1" x) (car x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	845 (Assert (eq (assq "1" x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	846 (Assert (eq (rassoc "1" x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	847 (Assert (eq (rassq "1" x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	848 (Assert (eq (assoc "2" x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	849 (Assert (eq (assq "2" x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	850 (Assert (eq (rassoc "2" x) (car x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	851 (Assert (eq (rassq "2" x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	852 (Assert (eq (assoc "3" x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	853 (Assert (eq (assq "3" x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	854 (Assert (eq (rassoc "3" x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	855 (Assert (eq (rassq "3" x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	856 (Assert (eq (assoc "4" x) (caddr x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	857 (Assert (eq (assq "4" x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	858 (Assert (eq (rassoc "4" x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	859 (Assert (eq (rassq "4" x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	860 (Assert (eq (assoc "5" x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	861 (Assert (eq (assq "5" x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	862 (Assert (eq (rassoc "5" x) (caddr x)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	863 (Assert (eq (rassq "5" x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	864 (Assert (eq (assoc "6" x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	865 (Assert (eq (assq "6" x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	866 (Assert (eq (rassoc "6" x) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	867 (Assert (eq (rassq "6" x) nil)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	868
5576 071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	869 (labels ((a () (list '(1 . 2) 3 '(4 . 5))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	870 (Assert (let* ((x (a)) (y (remassoc 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	871 (Assert (let* ((x (a)) (y (remassq 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	872 (Assert (let* ((x (a)) (y (remrassoc 1 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	873 (Assert (let* ((x (a)) (y (remrassq 1 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	874
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	875 (Assert (let* ((x (a)) (y (remassoc 2 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	876 (Assert (let* ((x (a)) (y (remassq 2 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	877 (Assert (let* ((x (a)) (y (remrassoc 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	878 (Assert (let* ((x (a)) (y (remrassq 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	879
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	880 (Assert (let* ((x (a)) (y (remassoc 3 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	881 (Assert (let* ((x (a)) (y (remassq 3 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	882 (Assert (let* ((x (a)) (y (remrassoc 3 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	883 (Assert (let* ((x (a)) (y (remrassq 3 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	884
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	885 (Assert (let* ((x (a)) (y (remassoc 4 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	886 (Assert (let* ((x (a)) (y (remassq 4 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	887 (Assert (let* ((x (a)) (y (remrassoc 4 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	888 (Assert (let* ((x (a)) (y (remrassq 4 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	889
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	890 (Assert (let* ((x (a)) (y (remassoc 5 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	891 (Assert (let* ((x (a)) (y (remassq 5 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	892 (Assert (let* ((x (a)) (y (remrassoc 5 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	893 (Assert (let* ((x (a)) (y (remrassq 5 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	894
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	895 (Assert (let* ((x (a)) (y (remassoc 6 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	896 (Assert (let* ((x (a)) (y (remassq 6 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	897 (Assert (let* ((x (a)) (y (remrassoc 6 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	898 (Assert (let* ((x (a)) (y (remrassq 6 x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	899 (Assert (let* ((x (a)) (y (delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	900 (Assert (let* ((x (a)) (y (delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	901 (Assert (let* ((x (a)) (y (delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	902 (Assert (let* ((x (a)) (y (delq '(1 . 2) x))) (and (eq x y) (equal y (a)))))
5374 d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	903 (when (and (fboundp 'old-eq) (subrp (symbol-function 'old-eq)))
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	904 (Assert (let* ((x (a)) (y (old-delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	905 (Assert (let* ((x (a)) (y (old-delq '(1 . 2) x))) (and (eq x y) (equal y (a)))))
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	906 (Assert (let* ((x (a)) (y (old-delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
d967d96ca043 Conditionalise the old-* functions and byte codes at compile time. Aidan Kehoe <kehoea@parhasard.net> parents: 5370 diff changeset	907 (Assert (let* ((x (a)) (y (old-delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	908
5576 071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	909 (labels ((a () (list '("1" . "2") "3" '("4" . "5"))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	910 (Assert (let* ((x (a)) (y (remassoc "1" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5"))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	911 (Assert (let* ((x (a)) (y (remassq "1" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	912 (Assert (let* ((x (a)) (y (remrassoc "1" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	913 (Assert (let* ((x (a)) (y (remrassq "1" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	914
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	915 (Assert (let* ((x (a)) (y (remassoc "2" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	916 (Assert (let* ((x (a)) (y (remassq "2" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	917 (Assert (let* ((x (a)) (y (remrassoc "2" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5"))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	918 (Assert (let* ((x (a)) (y (remrassq "2" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	919
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	920 (Assert (let* ((x (a)) (y (remassoc "3" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	921 (Assert (let* ((x (a)) (y (remassq "3" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	922 (Assert (let* ((x (a)) (y (remrassoc "3" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	923 (Assert (let* ((x (a)) (y (remrassq "3" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	924
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	925 (Assert (let* ((x (a)) (y (remassoc "4" x))) (and (eq x y) (equal y '(("1" . "2") "3")))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	926 (Assert (let* ((x (a)) (y (remassq "4" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	927 (Assert (let* ((x (a)) (y (remrassoc "4" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	928 (Assert (let* ((x (a)) (y (remrassq "4" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	929
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	930 (Assert (let* ((x (a)) (y (remassoc "5" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	931 (Assert (let* ((x (a)) (y (remassq "5" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	932 (Assert (let* ((x (a)) (y (remrassoc "5" x))) (and (eq x y) (equal y '(("1" . "2") "3")))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	933 (Assert (let* ((x (a)) (y (remrassq "5" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	934
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	935 (Assert (let* ((x (a)) (y (remassoc "6" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	936 (Assert (let* ((x (a)) (y (remassq "6" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	937 (Assert (let* ((x (a)) (y (remrassoc "6" x))) (and (eq x y) (equal y (a)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	938 (Assert (let* ((x (a)) (y (remrassq "6" x))) (and (eq x y) (equal y (a))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	939
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	940 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	941 ;; function-max-args, function-min-args
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	942 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	943 (defmacro check-function-argcounts (fun min max)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	944 `(progn
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	945 (Assert (eq (function-min-args ,fun) ,min))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	946 (Assert (eq (function-max-args ,fun) ,max))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	947
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	948 (check-function-argcounts 'prog1 1 nil) ; special form
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	949 (check-function-argcounts 'command-execute 1 3) ; normal subr
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	950 (check-function-argcounts 'funcall 1 nil) ; `MANY' subr
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	951 (check-function-argcounts 'garbage-collect 0 0) ; no args subr
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	952
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	953 ;; Test interpreted and compiled functions
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	954 (loop for (arglist min max) in
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	955 '(((arg1 arg2 &rest args) 2 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	956 ((arg1 arg2 &optional arg3 arg4) 2 4)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	957 ((arg1 arg2 &optional arg3 arg4 &rest args) 2 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	958 (() 0 0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	959 do
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	960 (eval
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	961 `(progn
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	962 (defun test-fun ,arglist nil)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	963 (check-function-argcounts '(lambda ,arglist nil) ,min ,max)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	964 (check-function-argcounts (byte-compile '(lambda ,arglist nil)) ,min ,max))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	965
4575 eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	966 ;; Test subr-arity.
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	967 (loop for (function-name arity) in
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	968 '((let (1 . unevalled))
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	969 (prog1 (1 . unevalled))
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	970 (list (0 . many))
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	971 (type-of (1 . 1))
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	972 (garbage-collect (0 . 0)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	973 do (Assert (equal (subr-arity (symbol-function function-name)) arity)))
4575 eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	974
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	975 (Check-Error wrong-type-argument (subr-arity
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	976 (lambda () (message "Hi there!"))))
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	977
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	978 (Check-Error wrong-type-argument (subr-arity nil))
eecd28508f4a Add #'subr-arity, API taken from GNU, implementation our own. Aidan Kehoe <kehoea@parhasard.net> parents: 4396 diff changeset	979
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	980 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	981 ;; Detection of cyclic variable indirection loops
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	982 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	983 (fset 'test-sym1 'test-sym1)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	984 (Check-Error cyclic-function-indirection (test-sym1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	985
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	986 (fset 'test-sym1 'test-sym2)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	987 (fset 'test-sym2 'test-sym1)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	988 (Check-Error cyclic-function-indirection (test-sym1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	989 (fmakunbound 'test-sym1) ; else macroexpand-internal infloops!
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	990 (fmakunbound 'test-sym2)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	991
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	992 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	993 ;; Test `type-of'
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	994 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	995 (Assert (eq (type-of load-path) 'cons))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	996 (Assert (eq (type-of obarray) 'vector))
5595 391d809fa4e9 Update tests that have started failing because of changed design decisions. Aidan Kehoe <kehoea@parhasard.net> parents: 5576 diff changeset	997 (Assert (eq (type-of 42) 'fixnum))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	998 (Assert (eq (type-of ?z) 'character))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	999 (Assert (eq (type-of "42") 'string))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1000 (Assert (eq (type-of 'foo) 'symbol))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1001 (Assert (eq (type-of (selected-device)) 'device))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1002
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1003 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1004 ;; Test mapping functions
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1005 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1006 (Check-Error wrong-type-argument (mapcar #'identity (current-buffer)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1007 (Assert (equal (mapcar #'identity load-path) load-path))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1008 (Assert (equal (mapcar #'identity '(1 2 3)) '(1 2 3)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1009 (Assert (equal (mapcar #'identity "123") '(?1 ?2 ?3)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1010 (Assert (equal (mapcar #'identity [1 2 3]) '(1 2 3)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1011 (Assert (equal (mapcar #'identity #*010) '(0 1 0)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1012
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1013 (let ((z 0) (list (make-list 1000 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1014 (mapc (lambda (x) (incf z x)) list)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1015 (Assert (eq 1000 z)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1016
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1017 (Check-Error wrong-type-argument (mapvector #'identity (current-buffer)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1018 (Assert (equal (mapvector #'identity '(1 2 3)) [1 2 3]))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1019 (Assert (equal (mapvector #'identity "123") [?1 ?2 ?3]))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1020 (Assert (equal (mapvector #'identity [1 2 3]) [1 2 3]))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1021 (Assert (equal (mapvector #'identity #*010) [0 1 0]))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1022
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1023 (Check-Error wrong-type-argument (mapconcat #'identity (current-buffer) "foo"))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1024 (Assert (equal (mapconcat #'identity '("1" "2" "3") "\|") "1\|2\|3"))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1025 (Assert (equal (mapconcat #'identity ["1" "2" "3"] "\|") "1\|2\|3"))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1026
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1027 ;; The following 2 functions used to crash XEmacs via mapcar1().
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1028 ;; We don't test the actual values of the mapcar, since they're undefined.
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1029 (Assert
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1030 (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3))))
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1031 (mapcar
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1032 (lambda (y)
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1033 "Devious evil mapping function"
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1034 (when (eq (car y) 2) ; go out onto a limb
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1035 (setcdr x nil) ; cut it off behind us
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1036 (garbage-collect)) ; are we riding a magic broomstick?
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1037 (car y)) ; sorry, hard landing
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1038 x)))
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1039
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1040 (Assert
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1041 (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3))))
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1042 (mapcar
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1043 (lambda (y)
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1044 "Devious evil mapping function"
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1045 (when (eq (car y) 1)
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1046 (setcdr (cdr x) 42)) ; drop a brick wall onto the freeway
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1047 (car y))
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1048 x)))
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1049
5355 70b15ac66ee5 Correct a bug with circularity checking in #'mapcar, #'map, etc. Aidan Kehoe <kehoea@parhasard.net>* parents: 5353 diff changeset	1050 (Assert
70b15ac66ee5 Correct a bug with circularity checking in #'mapcar, #'map, etc. Aidan Kehoe <kehoea@parhasard.net>* parents: 5353 diff changeset	1051 (equal
70b15ac66ee5 Correct a bug with circularity checking in #'mapcar, #'map, etc. Aidan Kehoe <kehoea@parhasard.net>* parents: 5353 diff changeset	1052 (let ((list (list pi))) (mapcar* #'cons [1 2 3 4] (nconc list list)))
70b15ac66ee5 Correct a bug with circularity checking in #'mapcar, #'map, etc. Aidan Kehoe <kehoea@parhasard.net>* parents: 5353 diff changeset	1053 `((1 . ,pi) (2 . ,pi) (3 . ,pi) (4 . ,pi)))
70b15ac66ee5 Correct a bug with circularity checking in #'mapcar, #'map, etc. Aidan Kehoe <kehoea@parhasard.net>* parents: 5353 diff changeset	1054 "checking mapcar* behaves correctly when only one arg is circular")
70b15ac66ee5 Correct a bug with circularity checking in #'mapcar, #'map, etc. Aidan Kehoe <kehoea@parhasard.net>* parents: 5353 diff changeset	1055
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1056 (Assert (eql
5034 1b96882bdf37 Fix a multiple-value bug, mapcarX; correct a comment and a label name. Aidan Kehoe <kehoea@parhasard.net> parents: 4906 diff changeset	1057 (length (multiple-value-list
1b96882bdf37 Fix a multiple-value bug, mapcarX; correct a comment and a label name. Aidan Kehoe <kehoea@parhasard.net> parents: 4906 diff changeset	1058 (car (mapcar #'(lambda (argument) (floor argument)) (list pi e)))))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1059 1)
5034 1b96882bdf37 Fix a multiple-value bug, mapcarX; correct a comment and a label name. Aidan Kehoe <kehoea@parhasard.net> parents: 4906 diff changeset	1060 "checking multiple values are correctly discarded in mapcar")
1b96882bdf37 Fix a multiple-value bug, mapcarX; correct a comment and a label name. Aidan Kehoe <kehoea@parhasard.net> parents: 4906 diff changeset	1061
5299 28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar Aidan Kehoe <kehoea@parhasard.net> parents: 5295 diff changeset	1062 (let ((malformed-list '(1 2 3 4 hi there . tail)))
28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar Aidan Kehoe <kehoea@parhasard.net> parents: 5295 diff changeset	1063 (Check-Error malformed-list (mapcar #'identity malformed-list))
28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar Aidan Kehoe <kehoea@parhasard.net> parents: 5295 diff changeset	1064 (Check-Error malformed-list (map nil #'eq [1 2 3 4]
28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar Aidan Kehoe <kehoea@parhasard.net> parents: 5295 diff changeset	1065 malformed-list))
28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar Aidan Kehoe <kehoea@parhasard.net> parents: 5295 diff changeset	1066 (Check-Error malformed-list (list-length malformed-list)))
28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar Aidan Kehoe <kehoea@parhasard.net> parents: 5295 diff changeset	1067
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1068 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1069 ;; Test vector functions
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1070 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1071 (Assert (equal [1 2 3] [1 2 3]))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1072 (Assert (equal [] []))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1073 (Assert (not (equal [1 2 3] [])))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1074 (Assert (not (equal [1 2 3] [1 2 4])))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1075 (Assert (not (equal [0 2 3] [1 2 3])))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1076 (Assert (not (equal [1 2 3] [1 2 3 4])))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1077 (Assert (not (equal [1 2 3 4] [1 2 3])))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1078 (Assert (equal (vector 1 2 3) [1 2 3]))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1079 (Assert (equal (make-vector 3 1) [1 1 1]))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1080
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1081 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1082 ;; Test bit-vector functions
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1083 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1084 (Assert (equal #010 #010))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1085 (Assert (equal #* #*))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1086 (Assert (not (equal #010 #011)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1087 (Assert (not (equal #010 #)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1088 (Assert (not (equal #110 #010)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1089 (Assert (not (equal #010 #0100)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1090 (Assert (not (equal #0101 #010)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1091 (Assert (equal (bit-vector 0 1 0) #*010))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1092 (Assert (equal (make-bit-vector 3 1) #*111))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1093 (Assert (equal (make-bit-vector 3 0) #*000))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1094
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1095 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1096 ;; Test buffer-local variables used as (ugh!) function parameters
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1097 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1098 (make-local-variable 'test-emacs-buffer-local-variable)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1099 (byte-compile
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1100 (defun test-emacs-buffer-local-parameter (test-emacs-buffer-local-variable)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1101 (setq test-emacs-buffer-local-variable nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1102 (test-emacs-buffer-local-parameter nil)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1103
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1104 ;;-----------------------------------------------------
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1105 ;; Test split-string
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	1106 ;;-----------------------------------------------------
1425 74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent] stephent parents: 826 diff changeset	1107 ;; Keep nulls, explicit SEPARATORS
74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent] stephent parents: 826 diff changeset	1108 ;; Hrvoje didn't like the next 3 tests so I'm disabling them for now. -sb
74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent] stephent parents: 826 diff changeset	1109 ;; I assume Hrvoje worried about the possibility of infloops. -sjt
74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent] stephent parents: 826 diff changeset	1110 (when test-harness-risk-infloops
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1111 (Assert (equal (split-string "foo" "") '("" "f" "o" "o" "")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1112 (Assert (equal (split-string "foo" "^") '("" "foo")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1113 (Assert (equal (split-string "foo" "$") '("foo" ""))))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1114 (Assert (equal (split-string "foo,bar" ",") '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1115 (Assert (equal (split-string ",foo,bar," ",") '("" "foo" "bar" "")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1116 (Assert (equal (split-string ",foo,bar," "^,") '("" "foo,bar,")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1117 (Assert (equal (split-string ",foo,bar," ",$") '(",foo,bar" "")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1118 (Assert (equal (split-string ",foo,,bar," ",") '("" "foo" "" "bar" "")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1119 (Assert (equal (split-string "foo,,,bar" ",") '("foo" "" "" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1120 (Assert (equal (split-string "foo,,bar,," ",") '("foo" "" "bar" "" "")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1121 (Assert (equal (split-string "foo,,bar" ",+") '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1122 (Assert (equal (split-string ",foo,,bar," ",+") '("" "foo" "bar" "")))
1425 74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent] stephent parents: 826 diff changeset	1123 ;; Omit nulls, explicit SEPARATORS
74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent] stephent parents: 826 diff changeset	1124 (when test-harness-risk-infloops
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1125 (Assert (equal (split-string "foo" "" t) '("f" "o" "o")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1126 (Assert (equal (split-string "foo" "^" t) '("foo")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1127 (Assert (equal (split-string "foo" "$" t) '("foo"))))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1128 (Assert (equal (split-string "foo,bar" "," t) '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1129 (Assert (equal (split-string ",foo,bar," "," t) '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1130 (Assert (equal (split-string ",foo,bar," "^," t) '("foo,bar,")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1131 (Assert (equal (split-string ",foo,bar," ",$" t) '(",foo,bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1132 (Assert (equal (split-string ",foo,,bar," "," t) '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1133 (Assert (equal (split-string "foo,,,bar" "," t) '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1134 (Assert (equal (split-string "foo,,bar,," "," t) '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1135 (Assert (equal (split-string "foo,,bar" ",+" t) '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1136 (Assert (equal (split-string ",foo,,bar," ",+" t) '("foo" "bar")))
1425 74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent] stephent parents: 826 diff changeset	1137 ;; "Double-default" case
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1138 (Assert (equal (split-string "foo bar") '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1139 (Assert (equal (split-string " foo bar ") '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1140 (Assert (equal (split-string " foo bar ") '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1141 (Assert (equal (split-string "foo bar") '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1142 (Assert (equal (split-string "foo bar ") '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1143 (Assert (equal (split-string "foobar") '("foobar")))
1425 74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent] stephent parents: 826 diff changeset	1144 ;; Semantics are identical to "double-default" case! Fool ya?
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1145 (Assert (equal (split-string "foo bar" nil t) '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1146 (Assert (equal (split-string " foo bar " nil t) '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1147 (Assert (equal (split-string " foo bar " nil t) '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1148 (Assert (equal (split-string "foo bar" nil t) '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1149 (Assert (equal (split-string "foo bar " nil t) '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1150 (Assert (equal (split-string "foobar" nil t) '("foobar")))
1425 74cb069b8417 [xemacs-hg @ 2003-04-23 15:42:44 by stephent] stephent parents: 826 diff changeset	1151 ;; Perverse "anti-double-default" case
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1152 (Assert (equal (split-string "foo bar" split-string-default-separators)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1153 '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1154 (Assert (equal (split-string " foo bar " split-string-default-separators)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1155 '("" "foo" "bar" "")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1156 (Assert (equal (split-string " foo bar " split-string-default-separators)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1157 '("" "foo" "bar" "")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1158 (Assert (equal (split-string "foo bar" split-string-default-separators)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1159 '("foo" "bar")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1160 (Assert (equal (split-string "foo bar " split-string-default-separators)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1161 '("foo" "bar" "")))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1162 (Assert (equal (split-string "foobar" split-string-default-separators)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1163 '("foobar")))
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1164
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1165 ;;-----------------------------------------------------
5035 b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1166 ;; Test split-string-by-char
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1167 ;;-----------------------------------------------------
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1168
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1169 (Assert
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1170 (equal
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1171 (split-string-by-char
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1172 #r"re\:ee:this\\is\\text\\\\:oo\ps:
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1173 Eine Sprache, die stagnirt, ist zu vergleichen mit einem See, dem der
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1174 bisherige Quellenzuflu� versiegt oder abgeleitet wird. Aus dem Wasser,
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1175 wor�ber der Geist Gottes schwebte, wird Sumpf und Moder, wor�ber die
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1176 unreinen\: Geister br�ten.\\
5036 9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1177 Serum concentrations of vitamin E: (alpha-tocopherol) depend on the liver,
9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1178 which takes up the nutrient after the various forms are absorbed from the
9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1179 small intestine. The liver preferentially resecretes only alpha-tocopherol
9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1180 via the hepatic alpha-tocopherol transfer protein"
5035 b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1181 ?: ?\\)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1182 '("re:ee" "this\\is\\text\\\\" "oops" "
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1183 Eine Sprache, die stagnirt, ist zu vergleichen mit einem See, dem der
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1184 bisherige Quellenzuflu� versiegt oder abgeleitet wird. Aus dem Wasser,
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1185 wor�ber der Geist Gottes schwebte, wird Sumpf und Moder, wor�ber die
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1186 unreinen: Geister br�ten.\\
5036 9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1187 Serum concentrations of vitamin E" " (alpha-tocopherol) depend on the liver,
9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1188 which takes up the nutrient after the various forms are absorbed from the
9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1189 small intestine. The liver preferentially resecretes only alpha-tocopherol
9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1190 via the hepatic alpha-tocopherol transfer protein")))
5035 b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1191 (Assert
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1192 (equal
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1193 (split-string-by-char
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1194 #r"re\:ee:this\\is\\text\\\\:oo\ps:
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1195 Eine Sprache, die stagnirt, ist zu vergleichen mit einem See, dem der
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1196 bisherige Quellenzuflu� versiegt oder abgeleitet wird. Aus dem Wasser,
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1197 wor�ber der Geist Gottes schwebte, wird Sumpf und Moder, wor�ber die
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1198 unreinen\: Geister br�ten.\\
5036 9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1199 Serum concentrations of vitamin E: (alpha-tocopherol) depend on the liver,
9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1200 which takes up the nutrient after the various forms are absorbed from the
9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1201 small intestine. The liver preferentially resecretes only alpha-tocopherol
9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1202 via the hepatic alpha-tocopherol transfer protein"
5035 b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1203 ?: ?\x00)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1204 '("re\\" "ee" "this\\\\is\\\\text\\\\\\\\" "oo\\ps" "
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1205 Eine Sprache, die stagnirt, ist zu vergleichen mit einem See, dem der
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1206 bisherige Quellenzuflu� versiegt oder abgeleitet wird. Aus dem Wasser,
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1207 wor�ber der Geist Gottes schwebte, wird Sumpf und Moder, wor�ber die
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1208 unreinen\\" " Geister br�ten.\\\\
5036 9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1209 Serum concentrations of vitamin E" " (alpha-tocopherol) depend on the liver,
9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1210 which takes up the nutrient after the various forms are absorbed from the
9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1211 small intestine. The liver preferentially resecretes only alpha-tocopherol
9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1212 via the hepatic alpha-tocopherol transfer protein")))
5035 b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1213 (Assert
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1214 (equal
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1215 (split-string-by-char
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1216 #r"re\:ee:this\\is\\text\\\\:oo\ps:
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1217 Eine Sprache, die stagnirt, ist zu vergleichen mit einem See, dem der
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1218 bisherige Quellenzuflu� versiegt oder abgeleitet wird. Aus dem Wasser,
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1219 wor�ber der Geist Gottes schwebte, wird Sumpf und Moder, wor�ber die
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1220 unreinen\: Geister br�ten.\\
5036 9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1221 Serum concentrations of vitamin E: (alpha-tocopherol) depend on the liver,
9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1222 which takes up the nutrient after the various forms are absorbed from the
9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1223 small intestine. The liver preferentially resecretes only alpha-tocopherol
9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1224 via the hepatic alpha-tocopherol transfer protein" ?\\)
5035 b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1225 '("re" ":ee:this" "" "is" "" "text" "" "" "" ":oo" "ps:
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1226 Eine Sprache, die stagnirt, ist zu vergleichen mit einem See, dem der
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1227 bisherige Quellenzuflu� versiegt oder abgeleitet wird. Aus dem Wasser,
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1228 wor�ber der Geist Gottes schwebte, wird Sumpf und Moder, wor�ber die
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1229 unreinen" ": Geister br�ten." "" "
5036 9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1230 Serum concentrations of vitamin E: (alpha-tocopherol) depend on the liver,
9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1231 which takes up the nutrient after the various forms are absorbed from the
9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1232 small intestine. The liver preferentially resecretes only alpha-tocopherol
9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1 Aidan Kehoe <kehoea@parhasard.net> parents: 5035 diff changeset	1233 via the hepatic alpha-tocopherol transfer protein")))
5035 b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1234
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char. Aidan Kehoe <kehoea@parhasard.net> parents: 5034 diff changeset	1235 ;;-----------------------------------------------------
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1236 ;; Test near-text buffer functions.
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1237 ;;-----------------------------------------------------
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1238 (with-temp-buffer
9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1239 (erase-buffer)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1240 (Assert (eq (char-before) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1241 (Assert (eq (char-before (point)) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1242 (Assert (eq (char-before (point-marker)) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1243 (Assert (eq (char-before (point) (current-buffer)) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1244 (Assert (eq (char-before (point-marker) (current-buffer)) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1245 (Assert (eq (char-after) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1246 (Assert (eq (char-after (point)) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1247 (Assert (eq (char-after (point-marker)) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1248 (Assert (eq (char-after (point) (current-buffer)) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1249 (Assert (eq (char-after (point-marker) (current-buffer)) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1250 (Assert (eq (preceding-char) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1251 (Assert (eq (preceding-char (current-buffer)) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1252 (Assert (eq (following-char) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1253 (Assert (eq (following-char (current-buffer)) 0))
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1254 (insert "foobar")
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1255 (Assert (eq (char-before) ?r))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1256 (Assert (eq (char-after) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1257 (Assert (eq (preceding-char) ?r))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1258 (Assert (eq (following-char) 0))
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1259 (goto-char (point-min))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1260 (Assert (eq (char-before) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1261 (Assert (eq (char-after) ?f))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1262 (Assert (eq (preceding-char) 0))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1263 (Assert (eq (following-char) ?f))
434 9d177e8d4150 Import from CVS: tag r21-2-25 cvs parents: 428 diff changeset	1264 )
440 8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1265
8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1266 ;;-----------------------------------------------------
8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1267 ;; Test plist manipulation functions.
8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1268 ;;-----------------------------------------------------
8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1269 (let ((sym (make-symbol "test-symbol")))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1270 (Assert (eq t (get* sym t t)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1271 (Assert (eq t (get sym t t)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1272 (Assert (eq t (getf nil t t)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1273 (Assert (eq t (plist-get nil t t)))
440 8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1274 (put sym 'bar 'baz)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1275 (Assert (eq 'baz (get sym 'bar)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1276 (Assert (eq 'baz (getf '(bar baz) 'bar)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1277 (Assert (eq 'baz (getf (symbol-plist sym) 'bar)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1278 (Assert (eq 2 (getf '(1 2) 1)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1279 (Assert (eq 4 (put sym 3 4)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1280 (Assert (eq 4 (get sym 3)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1281 (Assert (eq t (remprop sym 3)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1282 (Assert (eq nil (remprop sym 3)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1283 (Assert (eq 5 (get sym 3 5)))
440 8de8e3f6228a Import from CVS: tag r21-2-28 cvs parents: 434 diff changeset	1284 )
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1285
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1286 (loop for obj in
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1287 (list (make-symbol "test-symbol")
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1288 "test-string"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1289 (make-extent nil nil nil)
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1290 (make-face 'test-face))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1291 do
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1292 (Assert (eq 2 (get obj ?1 2)) obj)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1293 (Assert (eq 4 (put obj ?3 4)) obj)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1294 (Assert (eq 4 (get obj ?3)) obj)
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1295 (when (or (stringp obj) (symbolp obj))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1296 (Assert (equal '(?3 4) (object-plist obj)) obj))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1297 (Assert (eq t (remprop obj ?3)) obj)
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1298 (when (or (stringp obj) (symbolp obj))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1299 (Assert (eq '() (object-plist obj)) obj))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1300 (Assert (eq nil (remprop obj ?3)) obj)
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1301 (when (or (stringp obj) (symbolp obj))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1302 (Assert (eq '() (object-plist obj)) obj))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1303 (Assert (eq 5 (get obj ?3 5)) obj)
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1304 )
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1305
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1306 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1307 error "Object type has no properties"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1308 (get 2 'property))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1309
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1310 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1311 error "Object type has no settable properties"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1312 (put (current-buffer) 'property 'value))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1313
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1314 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1315 error "Object type has no removable properties"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1316 (remprop ?3 'property))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1317
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1318 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1319 error "Object type has no properties"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1320 (object-plist (symbol-function 'car)))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1321
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1322 (Check-Error-Message
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1323 error "Can't remove property from object"
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1324 (remprop (make-extent nil nil nil) 'detachable))
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1325
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1326 ;;-----------------------------------------------------
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1327 ;; Test subseq
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1328 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1329 (Assert (equal (subseq nil 0) nil))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1330 (Assert (equal (subseq [1 2 3] 0) [1 2 3]))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1331 (Assert (equal (subseq [1 2 3] 1 -1) [2]))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1332 (Assert (equal (subseq "123" 0) "123"))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1333 (Assert (equal (subseq "1234" -3 -1) "23"))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1334 (Assert (equal (subseq #0011 0) #0011))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1335 (Assert (equal (subseq #0011 -3 3) #01))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1336 (Assert (equal (subseq '(1 2 3) 0) '(1 2 3)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1337 (Assert (equal (subseq '(1 2 3 4) -3 nil) '(2 3 4)))
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1338
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1339 (Check-Error wrong-type-argument (subseq 3 2))
1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1340 (Check-Error args-out-of-range (subseq [1 2 3] -42))
1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1341 (Check-Error args-out-of-range (subseq [1 2 3] 0 42))
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1342
5370 4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1343 (let ((string "hi there"))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1344 (Assert (equal (substring-no-properties "123" 0) "123"))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1345 (Assert (equal (substring-no-properties "1234" -3 -1) "23"))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1346 (Assert (equal (substring-no-properties "hi there" 0) "hi there"))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1347 (put-text-property 0 (length string) 'foo 'bar string)
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1348 (Assert (eq 'bar (get-text-property 0 'foo string)))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1349 (Assert (not
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1350 (get-text-property 0 'foo (substring-no-properties "hi there" 0))))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1351 (Check-Error wrong-type-argument (substring-no-properties nil 4))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1352 (Check-Error wrong-type-argument (substring-no-properties "hi there" pi))
4c4b96b13f70 Address the easy test failures in tests/automated. Aidan Kehoe <kehoea@parhasard.net> parents: 5360 diff changeset	1353 (Check-Error wrong-type-argument (substring-no-properties "hi there" 0.0)))
5360 46b53e84ea7a #'substring-no-properties: check STRING's type, get_string_range_char won't. Aidan Kehoe <kehoea@parhasard.net> parents: 5355 diff changeset	1354
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1355 ;;-----------------------------------------------------
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1356 ;; Time-related tests
abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	1357 ;;-----------------------------------------------------
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1358 (Assert (= (length (current-time-string)) 24))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1359
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1360 ;;-----------------------------------------------------
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1361 ;; format test
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1362 ;;-----------------------------------------------------
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1363 (Assert (string= (format "%d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1364 (Assert (string= (format "%o" 8) "10"))
5295 2474dce7304e Make sure (format "%b" 0) is non-zero length, print.c Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	1365 (Assert (string= (format "%b" 2) "10"))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1366 (Assert (string= (format "%x" 31) "1f"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1367 (Assert (string= (format "%X" 31) "1F"))
5295 2474dce7304e Make sure (format "%b" 0) is non-zero length, print.c Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	1368 (Assert (string= (format "%b" 0) "0"))
2474dce7304e Make sure (format "%b" 0) is non-zero length, print.c Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	1369 (Assert (string= (format "%b" 3) "11"))
826 6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1370 ;; MS-Windows uses +002 in its floating-point numbers. #### We should
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1371 ;; perhaps fix this, but writing our own floating-point support in doprnt.c
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1372 ;; is very hard.
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1373 (Assert (or (string= (format "%e" 100) "1.000000e+02")
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1374 (string= (format "%e" 100) "1.000000e+002")))
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1375 (Assert (or (string= (format "%E" 100) "1.000000E+02")
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1376 (string= (format "%E" 100) "1.000000E+002")))
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1377 (Assert (or (string= (format "%E" 100) "1.000000E+02")
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1378 (string= (format "%E" 100) "1.000000E+002")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1379 (Assert (string= (format "%f" 100) "100.000000"))
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1380 (Assert (string= (format "%7.3f" 12.12345) " 12.123"))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1381 (Assert (string= (format "%07.3f" 12.12345) "012.123"))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1382 (Assert (string= (format "%-7.3f" 12.12345) "12.123 "))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1383 (Assert (string= (format "%-07.3f" 12.12345) "12.123 "))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1384 (Assert (string= (format "%g" 100.0) "100"))
826 6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1385 (Assert (or (string= (format "%g" 0.000001) "1e-06")
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1386 (string= (format "%g" 0.000001) "1e-006")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1387 (Assert (string= (format "%g" 0.0001) "0.0001"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1388 (Assert (string= (format "%G" 100.0) "100"))
826 6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1389 (Assert (or (string= (format "%G" 0.000001) "1E-06")
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1390 (string= (format "%G" 0.000001) "1E-006")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1391 (Assert (string= (format "%G" 0.0001) "0.0001"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1392
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1393 (Assert (string= (format "%2$d%1$d" 10 20) "2010"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1394 (Assert (string= (format "%-d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1395 (Assert (string= (format "%-4d" 10) "10 "))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1396 (Assert (string= (format "%+d" 10) "+10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1397 (Assert (string= (format "%+d" -10) "-10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1398 (Assert (string= (format "%+4d" 10) " +10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1399 (Assert (string= (format "%+4d" -10) " -10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1400 (Assert (string= (format "% d" 10) " 10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1401 (Assert (string= (format "% d" -10) "-10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1402 (Assert (string= (format "% 4d" 10) " 10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1403 (Assert (string= (format "% 4d" -10) " -10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1404 (Assert (string= (format "%0d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1405 (Assert (string= (format "%0d" -10) "-10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1406 (Assert (string= (format "%04d" 10) "0010"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1407 (Assert (string= (format "%04d" -10) "-010"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1408 (Assert (string= (format "%*d" 4 10) " 10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1409 (Assert (string= (format "%*d" 4 -10) " -10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1410 (Assert (string= (format "%*d" -4 10) "10 "))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1411 (Assert (string= (format "%*d" -4 -10) "-10 "))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1412 (Assert (string= (format "%#d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1413 (Assert (string= (format "%#o" 8) "010"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1414 (Assert (string= (format "%#x" 16) "0x10"))
826 6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1415 (Assert (or (string= (format "%#e" 100) "1.000000e+02")
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1416 (string= (format "%#e" 100) "1.000000e+002")))
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1417 (Assert (or (string= (format "%#E" 100) "1.000000E+02")
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1418 (string= (format "%#E" 100) "1.000000E+002")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1419 (Assert (string= (format "%#f" 100) "100.000000"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1420 (Assert (string= (format "%#g" 100.0) "100.000"))
826 6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1421 (Assert (or (string= (format "%#g" 0.000001) "1.00000e-06")
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1422 (string= (format "%#g" 0.000001) "1.00000e-006")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1423 (Assert (string= (format "%#g" 0.0001) "0.000100000"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1424 (Assert (string= (format "%#G" 100.0) "100.000"))
826 6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1425 (Assert (or (string= (format "%#G" 0.000001) "1.00000E-06")
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben] ben parents: 464 diff changeset	1426 (string= (format "%#G" 0.000001) "1.00000E-006")))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1427 (Assert (string= (format "%#G" 0.0001) "0.000100000"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1428 (Assert (string= (format "%.1d" 10) "10"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1429 (Assert (string= (format "%.4d" 10) "0010"))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1430 ;; Combination of `-', `+', ` ', `0', `#', `.', `*'
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1431 (Assert (string= (format "%-04d" 10) "10 "))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1432 (Assert (string= (format "%-*d" 4 10) "10 "))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1433 ;; #### Correctness of this behavior is questionable.
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1434 ;; It might be better to signal error.
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1435 (Assert (string= (format "%-*d" -4 10) "10 "))
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1436 ;; These behavior is not specified.
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1437 ;; (format "%-+d" 10)
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1438 ;; (format "%- d" 10)
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1439 ;; (format "%-01d" 10)
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1440 ;; (format "%-#4x" 10)
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1441 ;; (format "%-.1d" 10)
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1442
576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1443 (Assert (string= (format "%01.1d" 10) "10"))
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1444 (Assert (string= (format "%03.1d" 10) " 10"))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1445 (Assert (string= (format "%01.3d" 10) "010"))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1446 (Assert (string= (format "%1.3d" 10) "010"))
444 576fb035e263 Import from CVS: tag r21-2-37 cvs parents: 442 diff changeset	1447 (Assert (string= (format "%3.1d" 10) " 10"))
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1448
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1449 ;;; The following two tests used to use 1000 instead of 100,
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1450 ;;; but that merely found buffer overflow bugs in Solaris sprintf().
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1451 (Assert (= 102 (length (format "%.100f" 3.14))))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1452 (Assert (= 100 (length (format "%100f" 3.14))))
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1453
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1454 ;;; Check for 64-bit cleanness on LP64 platforms.
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1455 (Assert (= (read (format "%d" most-positive-fixnum)) most-positive-fixnum))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1456 (Assert (= (read (format "%ld" most-positive-fixnum)) most-positive-fixnum))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1457 (Assert (= (read (format "%u" most-positive-fixnum)) most-positive-fixnum))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1458 (Assert (= (read (format "%lu" most-positive-fixnum)) most-positive-fixnum))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1459 (Assert (= (read (format "%d" most-negative-fixnum)) most-negative-fixnum))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1460 (Assert (= (read (format "%ld" most-negative-fixnum)) most-negative-fixnum))
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1461
4287 89e64783d068 [xemacs-hg @ 2007-11-27 13:51:03 by aidan] aidan parents: 2075 diff changeset	1462 ;; These used to crash.
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1463 (Assert (eql (read (format "%f" 1.2e+302)) 1.2e+302))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1464 (Assert (eql (read (format "%.1000d" 1)) 1))
4287 89e64783d068 [xemacs-hg @ 2007-11-27 13:51:03 by aidan] aidan parents: 2075 diff changeset	1465
446 1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1466 ;;; "%u" is undocumented, and Emacs Lisp has no unsigned type.
1ccc32a20af4 Import from CVS: tag r21-2-38 cvs parents: 444 diff changeset	1467 ;;; What to do if "%u" is used with a negative number?
1983 9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	1468 ;;; For non-bignum XEmacsen, the most reasonable thing seems to be to print an
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	1469 ;;; un-read-able number. The printed value might be useful to a human, if not
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	1470 ;;; to Emacs Lisp.
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	1471 ;;; For bignum XEmacsen, we make %u with a negative value throw an error.
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	1472 (if (featurep 'bignum)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	1473 (progn
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	1474 (Check-Error wrong-type-argument (format "%u" most-negative-fixnum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james] james parents: 1425 diff changeset	1475 (Check-Error wrong-type-argument (format "%u" -1)))
5864 750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	1476 (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	1477 (Check-Error invalid-argument (read (format "%u" -1))))
448 3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1478
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1479 ;; Check all-completions ignore element start with space.
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1480 (Assert (not (all-completions "" '((" hidden" . "object")))))
3078fd1074e8 Import from CVS: tag r21-2-39 cvs parents: 446 diff changeset	1481 (Assert (all-completions " " '((" hidden" . "object"))))
4394 cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1482
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1483 (let* ((literal-with-uninterned
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1484 '(first-element
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1485 [#1=#:G32976 #2=#:G32974 #3=#:G32971 #4=#:G32969 alias
4396 e97f16fb2e25 Don't assume lisp-tests.el will be correctly read as UTF-8. Aidan Kehoe <kehoea@parhasard.net> parents: 4394 diff changeset	1486 #s(hash-table size 256 data (969 ?\xF9 55 ?7 166 ?\xA6))
4394 cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1487 #5=#:G32970 #6=#:G32972]))
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1488 (print-readably t)
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1489 (print-gensym t)
5560 58b38d5b32d0 Implement print-circle, allowing recursive and circular structures to be read. Aidan Kehoe <kehoea@parhasard.net> parents: 5553 diff changeset	1490 (print-continuous-numbering t)
4394 cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1491 (printed-with-uninterned (prin1-to-string literal-with-uninterned))
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1492 (awkward-regexp "#1=#")
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1493 (first-match-start (string-match awkward-regexp
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1494 printed-with-uninterned)))
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1495 (Assert (null (string-match awkward-regexp printed-with-uninterned
cacc942c0d0f Avoid clearing print-gensym-alist inappropriately when printing hash tables. Aidan Kehoe <kehoea@parhasard.net> parents: 4287 diff changeset	1496 (1+ first-match-start)))))
4580 1d11ecca9cd0 Print char table values correctly. Aidan Kehoe <kehoea@parhasard.net> parents: 4575 diff changeset	1497
1d11ecca9cd0 Print char table values correctly. Aidan Kehoe <kehoea@parhasard.net> parents: 4575 diff changeset	1498 (let ((char-table-with-string #s(char-table data (?\x00 "text")))
1d11ecca9cd0 Print char table values correctly. Aidan Kehoe <kehoea@parhasard.net> parents: 4575 diff changeset	1499 (char-table-with-symbol #s(char-table data (?\x00 text))))
4582 00ed9903a988 Fix make check after my last change. Aidan Kehoe <kehoea@parhasard.net> parents: 4580 diff changeset	1500 (Assert (not (string-equal (prin1-to-string char-table-with-string)
00ed9903a988 Fix make check after my last change. Aidan Kehoe <kehoea@parhasard.net> parents: 4580 diff changeset	1501 (prin1-to-string char-table-with-symbol)))
4580 1d11ecca9cd0 Print char table values correctly. Aidan Kehoe <kehoea@parhasard.net> parents: 4575 diff changeset	1502 "Check that char table elements are quoted correctly when printing"))
1d11ecca9cd0 Print char table values correctly. Aidan Kehoe <kehoea@parhasard.net> parents: 4575 diff changeset	1503
4608 1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1504
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1505 (let ((test-file-name
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1506 (make-temp-file (expand-file-name "sR4KDwU" (temp-directory))
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1507 nil ".el")))
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1508 (find-file test-file-name)
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1509 (erase-buffer)
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1510 (insert
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1511 "\
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1512 ;; Lisp should not be able to modify #$, which is
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1513 ;; Vload_file_name_internal of lread.c.
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1514 (Check-Error setting-constant (aset #$ 0 ?\\ ))
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1515
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1516 ;; But modifying load-file-name should work:
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1517 (let ((new-char ?\\ )
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1518 old-char)
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1519 (setq old-char (aref load-file-name 0))
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1520 (if (= new-char old-char)
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1521 (setq new-char ?/))
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1522 (aset load-file-name 0 new-char)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1523 (Assert (= new-char (aref load-file-name 0))
4608 1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1524 \"Check that we can modify the string value of load-file-name\"))
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1525
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1526 (let* ((new-load-file-name \"hi there\")
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1527 (load-file-name new-load-file-name))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1528 (Assert (eq new-load-file-name load-file-name)
4608 1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1529 \"Checking that we can bind load-file-name successfully.\"))
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1530
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1531 ")
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1532 (write-region (point-min) (point-max) test-file-name nil 'quiet)
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1533 (set-buffer-modified-p nil)
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1534 (kill-buffer nil)
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1535 (load test-file-name nil t nil)
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1536 (delete-file test-file-name))
1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	1537
5576 071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1538 (labels ((cl-floor (x &optional y)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1539 (let ((q (floor x y)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1540 (list q (- x (if y (* y q) q)))))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1541 (cl-ceiling (x &optional y)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1542 (let ((res (cl-floor x y)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1543 (if (= (car (cdr res)) 0) res
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1544 (list (1+ (car res)) (- (car (cdr res)) (or y 1))))))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1545 (cl-truncate (x &optional y)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1546 (if (eq (>= x 0) (or (null y) (>= y 0)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1547 (cl-floor x y) (cl-ceiling x y)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1548 (cl-round (x &optional y)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1549 (if y
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1550 (if (and (integerp x) (integerp y))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1551 (let* ((hy (/ y 2))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1552 (res (cl-floor (+ x hy) y)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1553 (if (and (= (car (cdr res)) 0)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1554 (= (+ hy hy) y)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1555 (/= (% (car res) 2) 0))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1556 (list (1- (car res)) hy)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1557 (list (car res) (- (car (cdr res)) hy))))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1558 (let ((q (round (/ x y))))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1559 (list q (- x (* q y)))))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1560 (if (integerp x) (list x 0)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1561 (let ((q (round x)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	1562 (list q (- x q))))))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1563 (Assert-rounding (first second &key
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1564 one-floor-result two-floor-result
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1565 one-ffloor-result two-ffloor-result
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1566 one-ceiling-result two-ceiling-result
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1567 one-fceiling-result two-fceiling-result
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1568 one-round-result two-round-result
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1569 one-fround-result two-fround-result
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1570 one-truncate-result two-truncate-result
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1571 one-ftruncate-result two-ftruncate-result)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1572 (Assert (equal one-floor-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1573 (floor first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1574 (format "checking (floor %S) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1575 first one-floor-result))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1576 (Assert (equal one-floor-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1577 (floor first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1578 (format "checking (floor %S 1) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1579 first one-floor-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1580 (Check-Error arith-error (floor first 0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1581 (Check-Error arith-error (floor first 0.0))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1582 (Assert (equal two-floor-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1583 (floor first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1584 (format
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1585 "checking (floor %S %S) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1586 first second two-floor-result))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1587 (Assert (equal (cl-floor first second)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1588 (multiple-value-list (floor first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1589 (format
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1590 "checking (floor %S %S) gives the same as the old code"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1591 first second))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1592 (Assert (equal one-ffloor-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1593 (ffloor first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1594 (format "checking (ffloor %S) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1595 first one-ffloor-result))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1596 (Assert (equal one-ffloor-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1597 (ffloor first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1598 (format "checking (ffloor %S 1) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1599 first one-ffloor-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1600 (Check-Error arith-error (ffloor first 0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1601 (Check-Error arith-error (ffloor first 0.0))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1602 (Assert (equal two-ffloor-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1603 (ffloor first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1604 (format "checking (ffloor %S %S) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1605 first second two-ffloor-result))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1606 (Assert (equal one-ceiling-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1607 (ceiling first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1608 (format "checking (ceiling %S) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1609 first one-ceiling-result))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1610 (Assert (equal one-ceiling-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1611 (ceiling first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1612 (format "checking (ceiling %S 1) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1613 first one-ceiling-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1614 (Check-Error arith-error (ceiling first 0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1615 (Check-Error arith-error (ceiling first 0.0))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1616 (Assert (equal two-ceiling-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1617 (ceiling first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1618 (format "checking (ceiling %S %S) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1619 first second two-ceiling-result))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1620 (Assert (equal (cl-ceiling first second)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1621 (multiple-value-list (ceiling first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1622 (format
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1623 "checking (ceiling %S %S) gives the same as the old code"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1624 first second))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1625 (Assert (equal one-fceiling-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1626 (fceiling first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1627 (format "checking (fceiling %S) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1628 first one-fceiling-result))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1629 (Assert (equal one-fceiling-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1630 (fceiling first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1631 (format "checking (fceiling %S 1) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1632 first one-fceiling-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1633 (Check-Error arith-error (fceiling first 0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1634 (Check-Error arith-error (fceiling first 0.0))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1635 (Assert (equal two-fceiling-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1636 (fceiling first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1637 (format "checking (fceiling %S %S) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1638 first second two-fceiling-result))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1639 (Assert (equal one-round-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1640 (round first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1641 (format "checking (round %S) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1642 first one-round-result))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1643 (Assert (equal one-round-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1644 (round first 1)))
4686 cdabd56ce1b5 Fix various small issues with the multiple-value implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 4679 diff changeset	1645 (format "checking (round %S 1) gives %S"
cdabd56ce1b5 Fix various small issues with the multiple-value implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 4679 diff changeset	1646 first one-round-result))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1647 (Check-Error arith-error (round first 0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1648 (Check-Error arith-error (round first 0.0))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1649 (Assert (equal two-round-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1650 (round first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1651 (format "checking (round %S %S) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1652 first second two-round-result))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1653 (Assert (equal one-fround-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1654 (fround first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1655 (format "checking (fround %S) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1656 first one-fround-result))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1657 (Assert (equal one-fround-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1658 (fround first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1659 (format "checking (fround %S 1) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1660 first one-fround-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1661 (Check-Error arith-error (fround first 0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1662 (Check-Error arith-error (fround first 0.0))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1663 (Assert (equal two-fround-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1664 (fround first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1665 (format "checking (fround %S %S) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1666 first second two-fround-result))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1667 (Assert (equal (cl-round first second)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1668 (multiple-value-list (round first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1669 (format
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1670 "checking (round %S %S) gives the same as the old code"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1671 first second))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1672 (Assert (equal one-truncate-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1673 (truncate first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1674 (format "checking (truncate %S) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1675 first one-truncate-result))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1676 (Assert (equal one-truncate-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1677 (truncate first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1678 (format "checking (truncate %S 1) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1679 first one-truncate-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1680 (Check-Error arith-error (truncate first 0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1681 (Check-Error arith-error (truncate first 0.0))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1682 (Assert (equal two-truncate-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1683 (truncate first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1684 (format "checking (truncate %S %S) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1685 first second two-truncate-result))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1686 (Assert (equal (cl-truncate first second)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1687 (multiple-value-list (truncate first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1688 (format
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1689 "checking (truncate %S %S) gives the same as the old code"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1690 first second))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1691 (Assert (equal one-ftruncate-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1692 (ftruncate first)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1693 (format "checking (ftruncate %S) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1694 first one-ftruncate-result))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1695 (Assert (equal one-ftruncate-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1696 (ftruncate first 1)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1697 (format "checking (ftruncate %S 1) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1698 first one-ftruncate-result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1699 (Check-Error arith-error (ftruncate first 0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1700 (Check-Error arith-error (ftruncate first 0.0))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1701 (Assert (equal two-ftruncate-result (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	1702 (ftruncate first second)))
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1703 (format "checking (ftruncate %S %S) gives %S"
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1704 first second two-ftruncate-result)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1705 (Assert-rounding-floating (pie ee)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1706 (let ((pie-type (type-of pie)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1707 (assert (eq pie-type (type-of ee)) t
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1708 "This code assumes the two arguments have the same type.")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1709 (Assert-rounding pie ee
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1710 :one-floor-result (list 3 (- pie 3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1711 :two-floor-result (list 1 (- pie (* 1 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1712 :one-ffloor-result (list (coerce 3 pie-type) (- pie 3.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1713 :two-ffloor-result (list (coerce 1 pie-type) (- pie (* 1.0 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1714 :one-ceiling-result (list 4 (- pie 4))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1715 :two-ceiling-result (list 2 (- pie (* 2 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1716 :one-fceiling-result (list (coerce 4 pie-type) (- pie 4.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1717 :two-fceiling-result (list (coerce 2 pie-type) (- pie (* 2.0 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1718 :one-round-result (list 3 (- pie 3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1719 :two-round-result (list 1 (- pie (* 1 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1720 :one-fround-result (list (coerce 3 pie-type) (- pie 3.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1721 :two-fround-result (list (coerce 1 pie-type) (- pie (* 1.0 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1722 :one-truncate-result (list 3 (- pie 3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1723 :two-truncate-result (list 1 (- pie (* 1 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1724 :one-ftruncate-result (list (coerce 3 pie-type) (- pie 3.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1725 :two-ftruncate-result (list (coerce 1 pie-type)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1726 (- pie (* 1.0 ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1727 (Assert-rounding pie (- ee)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1728 :one-floor-result (list 3 (- pie 3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1729 :two-floor-result (list -2 (- pie (* -2 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1730 :one-ffloor-result (list (coerce 3 pie-type) (- pie 3.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1731 :two-ffloor-result (list (coerce -2 pie-type)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1732 (- pie (* -2.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1733 :one-ceiling-result (list 4 (- pie 4))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1734 :two-ceiling-result (list -1 (- pie (* -1 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1735 :one-fceiling-result (list (coerce 4 pie-type) (- pie 4.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1736 :two-fceiling-result (list (coerce -1 pie-type)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1737 (- pie (* -1.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1738 :one-round-result (list 3 (- pie 3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1739 :two-round-result (list -1 (- pie (* -1 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1740 :one-fround-result (list (coerce 3 pie-type) (- pie 3.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1741 :two-fround-result (list (coerce -1 pie-type)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1742 (- pie (* -1.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1743 :one-truncate-result (list 3 (- pie 3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1744 :two-truncate-result (list -1 (- pie (* -1 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1745 :one-ftruncate-result (list (coerce 3 pie-type) (- pie 3.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1746 :two-ftruncate-result (list (coerce -1 pie-type)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1747 (- pie (* -1.0 (- ee)))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1748 (Assert-rounding (- pie) ee
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1749 :one-floor-result (list -4 (- (- pie) -4))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1750 :two-floor-result (list -2 (- (- pie) (* -2 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1751 :one-ffloor-result (list (coerce -4 pie-type) (- (- pie) -4.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1752 :two-ffloor-result (list (coerce -2 pie-type)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1753 (- (- pie) (* -2.0 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1754 :one-ceiling-result (list -3 (- (- pie) -3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1755 :two-ceiling-result (list -1 (- (- pie) (* -1 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1756 :one-fceiling-result (list (coerce -3 pie-type) (- (- pie) -3.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1757 :two-fceiling-result (list (coerce -1 pie-type)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1758 (- (- pie) (* -1.0 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1759 :one-round-result (list -3 (- (- pie) -3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1760 :two-round-result (list -1 (- (- pie) (* -1 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1761 :one-fround-result (list (coerce -3 pie-type) (- (- pie) -3.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1762 :two-fround-result (list (coerce -1 pie-type)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1763 (- (- pie) (* -1.0 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1764 :one-truncate-result (list -3 (- (- pie) -3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1765 :two-truncate-result (list -1 (- (- pie) (* -1 ee)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1766 :one-ftruncate-result (list (coerce -3 pie-type) (- (- pie) -3.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1767 :two-ftruncate-result (list (coerce -1 pie-type)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1768 (- (- pie) (* -1.0 ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1769 (Assert-rounding (- pie) (- ee)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1770 :one-floor-result (list -4 (- (- pie) -4))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1771 :two-floor-result (list 1 (- (- pie) (* 1 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1772 :one-ffloor-result (list (coerce -4 pie-type) (- (- pie) -4.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1773 :two-ffloor-result (list (coerce 1 pie-type)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1774 (- (- pie) (* 1.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1775 :one-ceiling-result (list -3 (- (- pie) -3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1776 :two-ceiling-result (list 2 (- (- pie) (* 2 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1777 :one-fceiling-result (list (coerce -3 pie-type) (- (- pie) -3.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1778 :two-fceiling-result (list (coerce 2 pie-type)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1779 (- (- pie) (* 2.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1780 :one-round-result (list -3 (- (- pie) -3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1781 :two-round-result (list 1 (- (- pie) (* 1 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1782 :one-fround-result (list (coerce -3 pie-type) (- (- pie) -3.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1783 :two-fround-result (list (coerce 1 pie-type)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1784 (- (- pie) (* 1.0 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1785 :one-truncate-result (list -3 (- (- pie) -3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1786 :two-truncate-result (list 1 (- (- pie) (* 1 (- ee))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1787 :one-ftruncate-result (list (coerce -3 pie-type) (- (- pie) -3.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1788 :two-ftruncate-result (list (coerce 1 pie-type)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1789 (- (- pie) (* 1.0 (- ee)))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1790 (Assert-rounding ee pie
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1791 :one-floor-result (list 2 (- ee 2))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1792 :two-floor-result (list 0 ee)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1793 :one-ffloor-result (list (coerce 2 pie-type) (- ee 2.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1794 :two-ffloor-result (list (coerce 0 pie-type) ee)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1795 :one-ceiling-result (list 3 (- ee 3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1796 :two-ceiling-result (list 1 (- ee pie))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1797 :one-fceiling-result (list (coerce 3 pie-type) (- ee 3.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1798 :two-fceiling-result (list (coerce 1 pie-type) (- ee pie))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1799 :one-round-result (list 3 (- ee 3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1800 :two-round-result (list 1 (- ee (* 1 pie)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1801 :one-fround-result (list (coerce 3 pie-type) (- ee 3.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1802 :two-fround-result (list (coerce 1 pie-type) (- ee (* 1.0 pie)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1803 :one-truncate-result (list 2 (- ee 2))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1804 :two-truncate-result (list 0 ee)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1805 :one-ftruncate-result (list (coerce 2 pie-type) (- ee 2.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1806 :two-ftruncate-result (list (coerce 0 pie-type) ee))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1807 (Assert-rounding ee (- pie)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1808 :one-floor-result (list 2 (- ee 2))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1809 :two-floor-result (list -1 (- ee (* -1 (- pie))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1810 :one-ffloor-result (list (coerce 2 pie-type) (- ee 2.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1811 :two-ffloor-result (list (coerce -1 pie-type)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1812 (- ee (* -1.0 (- pie))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1813 :one-ceiling-result (list 3 (- ee 3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1814 :two-ceiling-result (list 0 ee)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1815 :one-fceiling-result (list (coerce 3 pie-type) (- ee 3.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1816 :two-fceiling-result (list (coerce 0 pie-type) ee)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1817 :one-round-result (list 3 (- ee 3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1818 :two-round-result (list -1 (- ee (* -1 (- pie))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1819 :one-fround-result (list (coerce 3 pie-type) (- ee 3.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1820 :two-fround-result (list (coerce -1 pie-type)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1821 (- ee (* -1.0 (- pie))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1822 :one-truncate-result (list 2 (- ee 2))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1823 :two-truncate-result (list 0 ee)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1824 :one-ftruncate-result (list (coerce 2 pie-type) (- ee 2.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1825 :two-ftruncate-result (list (coerce 0 pie-type) ee)))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1826 ;; First, two integers:
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1827 (Assert-rounding 27 8 :one-floor-result '(27 0) :two-floor-result '(3 3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1828 :one-ffloor-result '(27.0 0) :two-ffloor-result '(3.0 3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1829 :one-ceiling-result '(27 0) :two-ceiling-result '(4 -5)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1830 :one-fceiling-result '(27.0 0) :two-fceiling-result '(4.0 -5)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1831 :one-round-result '(27 0) :two-round-result '(3 3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1832 :one-fround-result '(27.0 0) :two-fround-result '(3.0 3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1833 :one-truncate-result '(27 0) :two-truncate-result '(3 3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1834 :one-ftruncate-result '(27.0 0) :two-ftruncate-result '(3.0 3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1835 (Assert-rounding 27 -8 :one-floor-result '(27 0) :two-floor-result '(-4 -5)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1836 :one-ffloor-result '(27.0 0) :two-ffloor-result '(-4.0 -5)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1837 :one-ceiling-result '(27 0) :two-ceiling-result '(-3 3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1838 :one-fceiling-result '(27.0 0) :two-fceiling-result '(-3.0 3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1839 :one-round-result '(27 0) :two-round-result '(-3 3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1840 :one-fround-result '(27.0 0) :two-fround-result '(-3.0 3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1841 :one-truncate-result '(27 0) :two-truncate-result '(-3 3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1842 :one-ftruncate-result '(27.0 0) :two-ftruncate-result '(-3.0 3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1843 (Assert-rounding -27 8
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1844 :one-floor-result '(-27 0) :two-floor-result '(-4 5)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1845 :one-ffloor-result '(-27.0 0) :two-ffloor-result '(-4.0 5)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1846 :one-ceiling-result '(-27 0) :two-ceiling-result '(-3 -3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1847 :one-fceiling-result '(-27.0 0) :two-fceiling-result '(-3.0 -3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1848 :one-round-result '(-27 0) :two-round-result '(-3 -3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1849 :one-fround-result '(-27.0 0) :two-fround-result '(-3.0 -3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1850 :one-truncate-result '(-27 0) :two-truncate-result '(-3 -3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1851 :one-ftruncate-result '(-27.0 0) :two-ftruncate-result '(-3.0 -3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1852 (Assert-rounding -27 -8
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1853 :one-floor-result '(-27 0) :two-floor-result '(3 -3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1854 :one-ffloor-result '(-27.0 0) :two-ffloor-result '(3.0 -3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1855 :one-ceiling-result '(-27 0) :two-ceiling-result '(4 5)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1856 :one-fceiling-result '(-27.0 0) :two-fceiling-result '(4.0 5)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1857 :one-round-result '(-27 0) :two-round-result '(3 -3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1858 :one-fround-result '(-27.0 0) :two-fround-result '(3.0 -3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1859 :one-truncate-result '(-27 0) :two-truncate-result '(3 -3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1860 :one-ftruncate-result '(-27.0 0) :two-ftruncate-result '(3.0 -3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1861 (Assert-rounding 8 27
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1862 :one-floor-result '(8 0) :two-floor-result '(0 8)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1863 :one-ffloor-result '(8.0 0) :two-ffloor-result '(0.0 8)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1864 :one-ceiling-result '(8 0) :two-ceiling-result '(1 -19)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1865 :one-fceiling-result '(8.0 0) :two-fceiling-result '(1.0 -19)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1866 :one-round-result '(8 0) :two-round-result '(0 8)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1867 :one-fround-result '(8.0 0) :two-fround-result '(0.0 8)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1868 :one-truncate-result '(8 0) :two-truncate-result '(0 8)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1869 :one-ftruncate-result '(8.0 0) :two-ftruncate-result '(0.0 8))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1870 (Assert-rounding 8 -27
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1871 :one-floor-result '(8 0) :two-floor-result '(-1 -19)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1872 :one-ffloor-result '(8.0 0) :two-ffloor-result '(-1.0 -19)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1873 :one-ceiling-result '(8 0) :two-ceiling-result '(0 8)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1874 :one-fceiling-result '(8.0 0) :two-fceiling-result '(0.0 8)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1875 :one-round-result '(8 0) :two-round-result '(0 8)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1876 :one-fround-result '(8.0 0) :two-fround-result '(0.0 8)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1877 :one-truncate-result '(8 0) :two-truncate-result '(0 8)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1878 :one-ftruncate-result '(8.0 0) :two-ftruncate-result '(0.0 8))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1879 (Assert-rounding -8 27
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1880 :one-floor-result '(-8 0) :two-floor-result '(-1 19)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1881 :one-ffloor-result '(-8.0 0) :two-ffloor-result '(-1.0 19)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1882 :one-ceiling-result '(-8 0) :two-ceiling-result '(0 -8)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1883 :one-fceiling-result '(-8.0 0) :two-fceiling-result '(0.0 -8)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1884 :one-round-result '(-8 0) :two-round-result '(0 -8)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1885 :one-fround-result '(-8.0 0) :two-fround-result '(0.0 -8)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1886 :one-truncate-result '(-8 0) :two-truncate-result '(0 -8)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1887 :one-ftruncate-result '(-8.0 0) :two-ftruncate-result '(0.0 -8))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1888 (Assert-rounding -8 -27
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1889 :one-floor-result '(-8 0) :two-floor-result '(0 -8)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1890 :one-ffloor-result '(-8.0 0) :two-ffloor-result '(0.0 -8)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1891 :one-ceiling-result '(-8 0) :two-ceiling-result '(1 19)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1892 :one-fceiling-result '(-8.0 0) :two-fceiling-result '(1.0 19)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1893 :one-round-result '(-8 0) :two-round-result '(0 -8)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1894 :one-fround-result '(-8.0 0) :two-fround-result '(0.0 -8)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1895 :one-truncate-result '(-8 0) :two-truncate-result '(0 -8)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1896 :one-ftruncate-result '(-8.0 0) :two-ftruncate-result '(0.0 -8))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1897 (Assert-rounding 32 4
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1898 :one-floor-result '(32 0) :two-floor-result '(8 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1899 :one-ffloor-result '(32.0 0) :two-ffloor-result '(8.0 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1900 :one-ceiling-result '(32 0) :two-ceiling-result '(8 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1901 :one-fceiling-result '(32.0 0) :two-fceiling-result '(8.0 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1902 :one-round-result '(32 0) :two-round-result '(8 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1903 :one-fround-result '(32.0 0) :two-fround-result '(8.0 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1904 :one-truncate-result '(32 0) :two-truncate-result '(8 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1905 :one-ftruncate-result '(32.0 0) :two-ftruncate-result '(8.0 0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1906 (Assert-rounding 32 -4
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1907 :one-floor-result '(32 0) :two-floor-result '(-8 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1908 :one-ffloor-result '(32.0 0) :two-ffloor-result '(-8.0 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1909 :one-ceiling-result '(32 0) :two-ceiling-result '(-8 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1910 :one-fceiling-result '(32.0 0) :two-fceiling-result '(-8.0 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1911 :one-round-result '(32 0) :two-round-result '(-8 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1912 :one-fround-result '(32.0 0) :two-fround-result '(-8.0 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1913 :one-truncate-result '(32 0) :two-truncate-result '(-8 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1914 :one-ftruncate-result '(32.0 0) :two-ftruncate-result '(-8.0 0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1915 (Assert-rounding 12 9
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1916 :one-floor-result '(12 0) :two-floor-result '(1 3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1917 :one-ffloor-result '(12.0 0) :two-ffloor-result '(1.0 3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1918 :one-ceiling-result '(12 0) :two-ceiling-result '(2 -6)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1919 :one-fceiling-result '(12.0 0) :two-fceiling-result '(2.0 -6)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1920 :one-round-result '(12 0) :two-round-result '(1 3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1921 :one-fround-result '(12.0 0) :two-fround-result '(1.0 3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1922 :one-truncate-result '(12 0) :two-truncate-result '(1 3)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1923 :one-ftruncate-result '(12.0 0) :two-ftruncate-result '(1.0 3))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1924 (Assert-rounding 10 4
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1925 :one-floor-result '(10 0) :two-floor-result '(2 2)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1926 :one-ffloor-result '(10.0 0) :two-ffloor-result '(2.0 2)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1927 :one-ceiling-result '(10 0) :two-ceiling-result '(3 -2)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1928 :one-fceiling-result '(10.0 0) :two-fceiling-result '(3.0 -2)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1929 :one-round-result '(10 0) :two-round-result '(2 2)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1930 :one-fround-result '(10.0 0) :two-fround-result '(2.0 2)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1931 :one-truncate-result '(10 0) :two-truncate-result '(2 2)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1932 :one-ftruncate-result '(10.0 0) :two-ftruncate-result '(2.0 2))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1933 (Assert-rounding 14 4
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1934 :one-floor-result '(14 0) :two-floor-result '(3 2)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1935 :one-ffloor-result '(14.0 0) :two-ffloor-result '(3.0 2)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1936 :one-ceiling-result '(14 0) :two-ceiling-result '(4 -2)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1937 :one-fceiling-result '(14.0 0) :two-fceiling-result '(4.0 -2)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1938 :one-round-result '(14 0) :two-round-result '(4 -2)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1939 :one-fround-result '(14.0 0) :two-fround-result '(4.0 -2)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1940 :one-truncate-result '(14 0) :two-truncate-result '(3 2)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1941 :one-ftruncate-result '(14.0 0) :two-ftruncate-result '(3.0 2))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1942 ;; Now, two floats:
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1943 (Assert-rounding-floating pi e)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1944 (when (featurep 'bigfloat)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1945 (Assert-rounding-floating (coerce pi 'bigfloat) (coerce e 'bigfloat)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1946 (when (featurep 'bignum)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1947 (assert (not (evenp most-positive-fixnum)) t
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1948 "In the unlikely event that most-positive-fixnum is even, rewrite this.")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1949 (Assert-rounding (1+ most-positive-fixnum) (* 2 most-positive-fixnum)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1950 :one-floor-result `(,(1+ most-positive-fixnum) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1951 :two-floor-result `(0 ,(1+ most-positive-fixnum))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1952 :one-ffloor-result `(,(float (1+ most-positive-fixnum)) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1953 :two-ffloor-result `(0.0 ,(1+ most-positive-fixnum))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1954 :one-ceiling-result `(,(1+ most-positive-fixnum) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1955 :two-ceiling-result `(1 ,(1+ (- most-positive-fixnum)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1956 :one-fceiling-result `(,(float (1+ most-positive-fixnum)) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1957 :two-fceiling-result `(1.0 ,(1+ (- most-positive-fixnum)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1958 :one-round-result `(,(1+ most-positive-fixnum) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1959 :two-round-result `(1 ,(1+ (- most-positive-fixnum)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1960 :one-fround-result `(,(float (1+ most-positive-fixnum)) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1961 :two-fround-result `(1.0 ,(1+ (- most-positive-fixnum)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1962 :one-truncate-result `(,(1+ most-positive-fixnum) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1963 :two-truncate-result `(0 ,(1+ most-positive-fixnum))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1964 :one-ftruncate-result `(,(float (1+ most-positive-fixnum)) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1965 :two-ftruncate-result `(0.0 ,(1+ most-positive-fixnum)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1966 (Assert-rounding (1+ most-positive-fixnum) (- (* 2 most-positive-fixnum))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1967 :one-floor-result `(,(1+ most-positive-fixnum) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1968 :two-floor-result `(-1 ,(1+ (- most-positive-fixnum)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1969 :one-ffloor-result `(,(float (1+ most-positive-fixnum)) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1970 :two-ffloor-result `(-1.0 ,(1+ (- most-positive-fixnum)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1971 :one-ceiling-result `(,(1+ most-positive-fixnum) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1972 :two-ceiling-result `(0 ,(1+ most-positive-fixnum))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1973 :one-fceiling-result `(,(float (1+ most-positive-fixnum)) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1974 :two-fceiling-result `(0.0 ,(1+ most-positive-fixnum))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1975 :one-round-result `(,(1+ most-positive-fixnum) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1976 :two-round-result `(-1 ,(1+ (- most-positive-fixnum)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1977 :one-fround-result `(,(float (1+ most-positive-fixnum)) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1978 :two-fround-result `(-1.0 ,(1+ (- most-positive-fixnum)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1979 :one-truncate-result `(,(1+ most-positive-fixnum) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1980 :two-truncate-result `(0 ,(1+ most-positive-fixnum))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1981 :one-ftruncate-result `(,(float (1+ most-positive-fixnum)) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1982 :two-ftruncate-result `(0.0 ,(1+ most-positive-fixnum)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1983 (Assert-rounding (- (1+ most-positive-fixnum)) (* 2 most-positive-fixnum)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1984 :one-floor-result `(,(- (1+ most-positive-fixnum)) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1985 :two-floor-result `(-1 ,(1- most-positive-fixnum))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1986 :one-ffloor-result `(,(float (- (1+ most-positive-fixnum))) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1987 :two-ffloor-result `(-1.0 ,(1- most-positive-fixnum))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1988 :one-ceiling-result `(,(- (1+ most-positive-fixnum)) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1989 :two-ceiling-result `(0 ,(- (1+ most-positive-fixnum)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1990 :one-fceiling-result `(,(float (- (1+ most-positive-fixnum))) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1991 :two-fceiling-result `(0.0 ,(- (1+ most-positive-fixnum)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1992 :one-round-result `(,(- (1+ most-positive-fixnum)) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1993 :two-round-result `(-1 ,(1- most-positive-fixnum))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1994 :one-fround-result `(,(float (- (1+ most-positive-fixnum))) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1995 :two-fround-result `(-1.0 ,(1- most-positive-fixnum))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1996 :one-truncate-result `(,(- (1+ most-positive-fixnum)) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1997 :two-truncate-result `(0 ,(- (1+ most-positive-fixnum)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1998 :one-ftruncate-result `(,(float (- (1+ most-positive-fixnum))) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	1999 :two-ftruncate-result `(0.0 ,(- (1+ most-positive-fixnum))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2000 ;; Test the handling of values with .5:
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2001 (Assert-rounding (1+ (* 2 most-positive-fixnum)) 2
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2002 :one-floor-result `(,(1+ (* 2 most-positive-fixnum)) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2003 :two-floor-result `(,most-positive-fixnum 1)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2004 :one-ffloor-result `(,(float (1+ (* 2 most-positive-fixnum))) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2005 ;; We can't just call #'float here; we must use code that converts a
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2006 ;; bignum with value most-positive-fixnum (the creation of which is
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2007 ;; not directly possible in Lisp) to a float, not code that converts
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2008 ;; the fixnum with value most-positive-fixnum to a float. The eval is
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2009 ;; to avoid compile-time optimisation that can break this.
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2010 :two-ffloor-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) 1)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2011 :one-ceiling-result `(,(1+ (* 2 most-positive-fixnum)) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2012 :two-ceiling-result `(,(1+ most-positive-fixnum) -1)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2013 :one-fceiling-result `(,(float (1+ (* 2 most-positive-fixnum))) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2014 :two-fceiling-result `(,(float (1+ most-positive-fixnum)) -1)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2015 :one-round-result `(,(1+ (* 2 most-positive-fixnum)) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2016 :two-round-result `(,(1+ most-positive-fixnum) -1)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2017 :one-fround-result `(,(float (1+ (* 2 most-positive-fixnum))) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2018 :two-fround-result `(,(float (1+ most-positive-fixnum)) -1)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2019 :one-truncate-result `(,(1+ (* 2 most-positive-fixnum)) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2020 :two-truncate-result `(,most-positive-fixnum 1)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2021 :one-ftruncate-result `(,(float (1+ (* 2 most-positive-fixnum))) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2022 ;; See the comment above on :two-ffloor-result:
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2023 :two-ftruncate-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) 1))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2024 (Assert-rounding (1+ (* 2 (1- most-positive-fixnum))) 2
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2025 :one-floor-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2026 :two-floor-result `(,(1- most-positive-fixnum) 1)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2027 :one-ffloor-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2028 ;; See commentary above on float conversions.
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2029 :two-ffloor-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) 1)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2030 :one-ceiling-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2031 :two-ceiling-result `(,most-positive-fixnum -1)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2032 :one-fceiling-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2033 :two-fceiling-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) -1)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2034 :one-round-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2035 :two-round-result `(,(1- most-positive-fixnum) 1)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2036 :one-fround-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2037 :two-fround-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) 1)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2038 :one-truncate-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2039 :two-truncate-result `(,(1- most-positive-fixnum) 1)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2040 :one-ftruncate-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2041 ;; See commentary above
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2042 :two-ftruncate-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2043 1)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2044 (when (featurep 'ratio)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2045 (Assert-rounding (read "4/3") (read "8/7")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2046 :one-floor-result '(1 1/3) :two-floor-result '(1 4/21)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2047 :one-ffloor-result '(1.0 1/3) :two-ffloor-result '(1.0 4/21)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2048 :one-ceiling-result '(2 -2/3) :two-ceiling-result '(2 -20/21)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2049 :one-fceiling-result '(2.0 -2/3) :two-fceiling-result '(2.0 -20/21)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2050 :one-round-result '(1 1/3) :two-round-result '(1 4/21)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2051 :one-fround-result '(1.0 1/3) :two-fround-result '(1.0 4/21)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2052 :one-truncate-result '(1 1/3) :two-truncate-result '(1 4/21)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2053 :one-ftruncate-result '(1.0 1/3) :two-ftruncate-result '(1.0 4/21))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2054 (Assert-rounding (read "-4/3") (read "8/7")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2055 :one-floor-result '(-2 2/3) :two-floor-result '(-2 20/21)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2056 :one-ffloor-result '(-2.0 2/3) :two-ffloor-result '(-2.0 20/21)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2057 :one-ceiling-result '(-1 -1/3) :two-ceiling-result '(-1 -4/21)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2058 :one-fceiling-result '(-1.0 -1/3) :two-fceiling-result '(-1.0 -4/21)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2059 :one-round-result '(-1 -1/3) :two-round-result '(-1 -4/21)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2060 :one-fround-result '(-1.0 -1/3) :two-fround-result '(-1.0 -4/21)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2061 :one-truncate-result '(-1 -1/3) :two-truncate-result '(-1 -4/21)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2062 :one-ftruncate-result '(-1.0 -1/3) :two-ftruncate-result '(-1.0 -4/21))))
4608 1e3cf11fa27d Make #$ truly read-only for Lisp; check this in the test suite. Aidan Kehoe <kehoea@parhasard.net> parents: 4582 diff changeset	2063
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2064 ;; Run this function in a Common Lisp with two arguments to get results that
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2065 ;; we should compare against, above. Though note the dancing-around with the
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2066 ;; bigfloats and bignums above, too; you can't necessarily just use the
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2067 ;; output here.
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2068
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2069 (defun generate-rounding-output (first second)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2070 (let ((print-readably t))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2071 (princ first)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2072 (princ " ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2073 (princ second)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2074 (princ " :one-floor-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2075 (princ (list 'quote (multiple-value-list (floor first))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2076 (princ " :two-floor-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2077 (princ (list 'quote (multiple-value-list (floor first second))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2078 (princ " :one-ffloor-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2079 (princ (list 'quote (multiple-value-list (ffloor first))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2080 (princ " :two-ffloor-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2081 (princ (list 'quote (multiple-value-list (ffloor first second))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2082 (princ " :one-ceiling-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2083 (princ (list 'quote (multiple-value-list (ceiling first))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2084 (princ " :two-ceiling-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2085 (princ (list 'quote (multiple-value-list (ceiling first second))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2086 (princ " :one-fceiling-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2087 (princ (list 'quote (multiple-value-list (fceiling first))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2088 (princ " :two-fceiling-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2089 (princ (list 'quote (multiple-value-list (fceiling first second))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2090 (princ " :one-round-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2091 (princ (list 'quote (multiple-value-list (round first))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2092 (princ " :two-round-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2093 (princ (list 'quote (multiple-value-list (round first second))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2094 (princ " :one-fround-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2095 (princ (list 'quote (multiple-value-list (fround first))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2096 (princ " :two-fround-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2097 (princ (list 'quote (multiple-value-list (fround first second))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2098 (princ " :one-truncate-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2099 (princ (list 'quote (multiple-value-list (truncate first))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2100 (princ " :two-truncate-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2101 (princ (list 'quote (multiple-value-list (truncate first second))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2102 (princ " :one-ftruncate-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2103 (princ (list 'quote (multiple-value-list (ftruncate first))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2104 (princ " :two-ftruncate-result ")
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4608 diff changeset	2105 (princ (list 'quote (multiple-value-list (ftruncate first second))))))
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2106
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2107 ;; Multiple value tests.
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2108
5576 071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2109 (labels ((foo (x y)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2110 (floor (+ x y) y))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2111 (foo-zero (x y)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2112 (values (floor (+ x y) y)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2113 (multiple-value-function-returning-t ()
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2114 (values t pi e degrees-to-radians radians-to-degrees))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2115 (multiple-value-function-returning-nil ()
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2116 (values nil pi e radians-to-degrees degrees-to-radians))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2117 (function-throwing-multiple-values ()
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2118 (let* ((listing '(0 3 4 nil "string" symbol))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2119 (tail listing)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2120 elt)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2121 (while t
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2122 (setq tail (cdr listing)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2123 elt (car listing)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2124 listing tail)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2125 (when (null elt)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2126 (throw 'VoN61Lo4Y (multiple-value-function-returning-t)))))))
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2127 (Assert
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2128 (= (+ (floor 5 3) (floor 19 4)) (+ 1 4) 5)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2129 "Checking that multiple values are discarded correctly as func args")
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2130 (Assert
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2131 (= 2 (length (multiple-value-list (foo 400 (1+ most-positive-fixnum)))))
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2132 "Checking multiple values are passed through correctly as return values")
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2133 (Assert
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2134 (= 1 (length (multiple-value-list
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2135 (foo-zero 400 (1+ most-positive-fixnum)))))
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2136 "Checking multiple values are discarded correctly when forced")
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2137 (Check-Error setting-constant (setq multiple-values-limit 20))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2138 (Assert (equal '(-1 1)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2139 (multiple-value-list (floor -3 4)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2140 "Checking #'multiple-value-list gives a sane result")
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2141 (let ((ey 40000)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2142 (bee "this is a string")
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2143 (cee #s(hash-table size 256 data (969 ?\xF9))))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2144 (Assert (equal
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2145 (multiple-value-list (values ey bee cee))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2146 (multiple-value-list (values-list (list ey bee cee))))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2147 "Checking that #'values and #'values-list are correctly related")
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2148 (Assert (equal
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2149 (multiple-value-list (values-list (list ey bee cee)))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2150 (multiple-value-list (apply #'values (list ey bee cee))))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2151 "Checking #'values-list and #'apply with #values are correctly related"))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2152 (Assert (= (multiple-value-call #'+ (floor 5 3) (floor 19 4)) 10)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2153 "Checking #'multiple-value-call gives reasonable results.")
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2154 (Assert (= (multiple-value-call (values '+ '*) (floor 5 3) (floor 19 4)) 10)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2155 "Checking #'multiple-value-call correct when first arg multiple.")
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2156 (Assert (= 1 (length (multiple-value-list (prog1 (floor pi) "hi there"))))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2157 "Checking #'prog1 does not pass back multiple values")
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2158 (Assert (= 2 (length (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2159 (multiple-value-prog1 (floor pi) "hi there"))))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2160 "Checking #'multiple-value-prog1 passes back multiple values")
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2161 (multiple-value-bind (floored remainder this-is-nil)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2162 (floor pi 1.0)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2163 (Assert (= floored 3)
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2164 "Checking floored bound correctly")
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2165 (Assert (eql remainder (- pi 3.0))
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2166 "Checking remainder bound correctly")
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2167 (Assert (null this-is-nil)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2168 "Checking trailing arg bound but nil"))
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2169 (let ((ey 40000)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2170 (bee "this is a string")
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2171 (cee #s(hash-table size 256 data (969 ?\xF9))))
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2172 (multiple-value-setq (ey bee cee)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2173 (ffloor e 1.0))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2174 (Assert (eql 2.0 ey) "Checking ey set correctly")
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2175 (Assert (eql bee (- e 2.0)) "Checking bee set correctly")
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2176 (Assert (null cee) "Checking cee set to nil correctly"))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2177 (Assert (= 3 (length (multiple-value-list (eval '(values nil t pi)))))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2178 "Checking #'eval passes back multiple values")
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2179 (Assert (= 2 (length (multiple-value-list (apply #'floor '(5 3)))))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2180 "Checking #'apply passes back multiple values")
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2181 (Assert (= 2 (length (multiple-value-list (funcall #'floor 5 3))))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2182 "Checking #'funcall passes back multiple values")
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2183 (Assert (equal '(1 2) (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2184 (multiple-value-call #'floor (values 5 3))))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2185 "Checking #'multiple-value-call passes back multiple values correctly")
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2186 (Assert (= 1 (length (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2187 (and (multiple-value-function-returning-nil) t))))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2188 "Checking multiple values from non-trailing forms discarded by #'and")
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2189 (Assert (= 5 (length (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2190 (and t (multiple-value-function-returning-nil)))))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2191 "Checking multiple values from final forms not discarded by #'and")
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2192 (Assert (= 1 (length (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2193 (or (multiple-value-function-returning-t) t))))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2194 "Checking multiple values from non-trailing forms discarded by #'and")
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2195 (Assert (= 5 (length (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2196 (or nil (multiple-value-function-returning-t)))))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2197 "Checking multiple values from final forms not discarded by #'and")
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2198 (Assert (= 1 (length (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2199 (cond ((multiple-value-function-returning-t))))))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2200 "Checking cond doesn't pass back multiple values in tests.")
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2201 (Assert (equal (list nil pi e radians-to-degrees degrees-to-radians)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2202 (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2203 (cond (t (multiple-value-function-returning-nil)))))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2204 "Checking cond passes back multiple values in clauses.")
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2205 (Assert (= 1 (length (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2206 (prog1 (multiple-value-function-returning-nil)))))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2207 "Checking prog1 discards multiple values correctly.")
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2208 (Assert (= 5 (length (multiple-value-list
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2209 (multiple-value-prog1
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2210 (multiple-value-function-returning-nil)))))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2211 "Checking multiple-value-prog1 passes back multiple values correctly.")
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2212 (Assert (equal (list t pi e degrees-to-radians radians-to-degrees)
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2213 (multiple-value-list
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2214 (catch 'VoN61Lo4Y (function-throwing-multiple-values)))))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2215 (Assert (equal (list t pi e degrees-to-radians radians-to-degrees)
4679 2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2216 (multiple-value-list
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2217 (loop
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2218 for eye in `(a b c d ,e f g ,nil ,pi)
2c64d2bbb316 Test the multiple-value functionality. Aidan Kehoe <kehoea@parhasard.net> parents: 4678 diff changeset	2219 do (when (null eye)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2220 (return (multiple-value-function-returning-t))))))
4686 cdabd56ce1b5 Fix various small issues with the multiple-value implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 4679 diff changeset	2221 "Checking #'loop passes back multiple values correctly.")
cdabd56ce1b5 Fix various small issues with the multiple-value implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 4679 diff changeset	2222 (Assert
cdabd56ce1b5 Fix various small issues with the multiple-value implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 4679 diff changeset	2223 (null (or))
cdabd56ce1b5 Fix various small issues with the multiple-value implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 4679 diff changeset	2224 "Checking #'or behaves correctly with zero arguments.")
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2225 (Assert (eq t (and))
4686 cdabd56ce1b5 Fix various small issues with the multiple-value implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 4679 diff changeset	2226 "Checking #'and behaves correctly with zero arguments.")
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2227 (Assert (= (* 3.0 (- pi 3.0))
4742 4cf435fcebbc Make #'letf not error if handed a #'values form. Aidan Kehoe <kehoea@parhasard.net> parents: 4732 diff changeset	2228 (letf (((values three one-four-one-five-nine) (floor pi)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2229 (* three one-four-one-five-nine)))
4742 4cf435fcebbc Make #'letf not error if handed a #'values form. Aidan Kehoe <kehoea@parhasard.net> parents: 4732 diff changeset	2230 "checking letf handles #'values in a basic sense"))
4686 cdabd56ce1b5 Fix various small issues with the multiple-value implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 4679 diff changeset	2231
4792 95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2232 ;; #'equalp tests.
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2233 (let ((string-variable "aBcDeeFgH\u00Edj")
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2234 (eacute-character ?\u00E9)
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2235 (Eacute-character ?\u00c9)
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2236 (+base-chars+ (loop
4906 6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps Ben Wing <ben@xemacs.org> parents: 4897 diff changeset	2237 with res = (make-string 96 ?\x20)
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps Ben Wing <ben@xemacs.org> parents: 4897 diff changeset	2238 for int-char from #x20 to #x7f
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps Ben Wing <ben@xemacs.org> parents: 4897 diff changeset	2239 for char being each element in-ref res
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps Ben Wing <ben@xemacs.org> parents: 4897 diff changeset	2240 do (setf char (int-to-char int-char))
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps Ben Wing <ben@xemacs.org> parents: 4897 diff changeset	2241 finally return res)))
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps Ben Wing <ben@xemacs.org> parents: 4897 diff changeset	2242
5188 000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2243 (macrolet
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2244 ((equalp-equal-list-tests (equal-list)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2245 (let (res)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2246 (setq equal-lists (eval equal-list))
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2247 (loop for li in equal-lists do
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2248 (loop for (x . tail) on li do
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2249 (loop for y in tail do
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2250 (push `(Assert (equalp ,(quote-maybe x)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2251 ,(quote-maybe y))) res)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2252 (push `(Assert (equalp ,(quote-maybe y)
5191 71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2253 ,(quote-maybe x))) res)
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2254 (push `(Assert (eql (equalp-hash ,(quote-maybe y))
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2255 (equalp-hash ,(quote-maybe x))))
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2256 res))))
5188 000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2257 (cons 'progn (nreverse res))))
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2258 (equalp-diff-list-tests (diff-list)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2259 (let (res)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2260 (setq diff-list (eval diff-list))
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2261 (loop for (x . tail) on diff-list do
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2262 (loop for y in tail do
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2263 (push `(Assert (not (equalp ,(quote-maybe x)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2264 ,(quote-maybe y)))) res)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2265 (push `(Assert (not (equalp ,(quote-maybe y)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2266 ,(quote-maybe x)))) res)))
5191 71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2267 (cons 'progn (nreverse res))))
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2268 (Assert-equalp (object-one object-two &optional failing-case description)
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2269 `(progn
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2270 (Assert (equalp ,object-one ,object-two)
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2271 ,@(if failing-case
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2272 (list failing-case description)))
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2273 (Assert (eql (equalp-hash ,object-one) (equalp-hash ,object-two))))))
5188 000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2274 (equalp-equal-list-tests
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2275 `(,@(when (featurep 'bignum)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2276 (read "((111111111111111111111111111111111111111111111111111
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2277 111111111111111111111111111111111111111111111111111.0))"))
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2278 (0 0.0 0.000 -0 -0.0 -0.000 #b0 ,@(when (featurep 'ratio) '(0/5 -0/5)))
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2279 (21845 #b101010101010101 #x5555)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2280 (1.5 1.500000000000000000000000000000000000000000000000000000000
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2281 ,@(when (featurep 'ratio) '(3/2)))
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2282 ;; Can't use this, these values aren't `='.
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2283 ;;(-12345678901234567890123457890123457890123457890123457890123457890
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2284 ;; -12345678901234567890123457890123457890123457890123457890123457890.0)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2285 (-55 -55.000 ,@(when (featurep 'ratio) '(-110/2)))))
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2286 (equalp-diff-list-tests
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2287 `(0 1 2 3 1000 5000000000
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2288 ,@(when (featurep 'bignum)
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2289 (read "(5555555555555555555555555555555555555
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2290 -5555555555555555555555555555555555555)"))
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2291 -1 -2 -3 -1000 -5000000000
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2292 1/2 1/3 2/3 8/2 355/113
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2293 ,@(when (featurep 'ratio) (mapcar* #'/ '(3/2 3/2) '(0.2 0.7)))
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2294 55555555555555555555555555555555555555555/2718281828459045
000287f8053b Be more careful about parentheses and number features, #'equalp tests Aidan Kehoe <kehoea@parhasard.net> parents: 5136 diff changeset	2295 0.111111111111111111111111111111111111111111111111111111111111111
5191 71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2296 1e+300 1e+301 -1e+300 -1e+301))
4906 6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps Ben Wing <ben@xemacs.org> parents: 4897 diff changeset	2297
5191 71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2298 (Assert-equalp "hi there" "Hi There"
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2299 "checking equalp isn't case-sensitive")
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2300 (Assert-equalp
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2301 99 99.0
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2302 "checking equalp compares numerical values of different types")
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2303 (Assert (null (equalp 99 ?c))
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2304 "checking equalp does not convert characters to numbers")
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2305 ;; Fixed in Hg d0ea57eb3de4.
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2306 (Assert (null (equalp "hi there" [hi there]))
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2307 "checking equalp doesn't error with string and non-string")
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2308 (Assert-equalp
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2309 "ABCDEEFGH\u00CDJ" string-variable
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2310 "checking #'equalp is case-insensitive with an upcased constant")
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2311 (Assert-equalp
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2312 "abcdeefgh\xedj" string-variable
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2313 "checking #'equalp is case-insensitive with a downcased constant")
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2314 (Assert-equalp string-variable string-variable
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2315 "checking #'equalp works when handed the same string twice")
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2316 (Assert (equalp string-variable "aBcDeeFgH\u00Edj")
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2317 "check #'equalp is case-insensitive with a variable-cased constant")
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2318 (Assert-equalp "" (bit-vector)
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2319 "check empty string and empty bit-vector are #'equalp.")
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2320 (Assert-equalp
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2321 (string) (bit-vector)
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2322 "check empty string and empty bit-vector are #'equalp, no constants")
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2323 (Assert-equalp "hi there" (vector ?h ?i ?\ ?t ?h ?e ?r ?e)
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2324 "check string and vector with same contents #'equalp")
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2325 (Assert-equalp
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2326 (string ?h ?i ?\ ?t ?h ?e ?r ?e)
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2327 (vector ?h ?i ?\ ?t ?h ?e ?r ?e)
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2328 "check string and vector with same contents #'equalp, no constants")
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2329 (Assert-equalp
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2330 [?h ?i ?\ ?t ?h ?e ?r ?e]
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2331 (string ?h ?i ?\ ?t ?h ?e ?r ?e)
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2332 "check string and vector with same contents #'equalp, vector constant")
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2333 (Assert-equalp [0 1.0 0.0 0 1]
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2334 (bit-vector 0 1 0 0 1)
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2335 "check vector and bit-vector with same contents #'equalp,\
4906 6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps Ben Wing <ben@xemacs.org> parents: 4897 diff changeset	2336 vector constant")
5191 71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2337 (Assert (not (equalp [0 2 0.0 0 1]
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2338 (bit-vector 0 1 0 0 1)))
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2339 "check vector and bit-vector with different contents not #'equalp,\
4792 95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2340 vector constant")
5191 71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2341 (Assert-equalp #*01001
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2342 (vector 0 1.0 0.0 0 1)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2343 "check vector and bit-vector with same contents #'equalp,\
4792 95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2344 bit-vector constant")
5191 71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2345 (Assert-equalp ?\u00E9 Eacute-character
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2346 "checking characters are case-insensitive, one constant")
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2347 (Assert (not (equalp ?\u00E9 (aref (format "%c" ?a) 0)))
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2348 "checking distinct characters are not equalp, one constant")
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2349 (Assert-equalp t (and)
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2350 "checking symbols are correctly #'equalp")
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2351 (Assert (not (equalp t (or nil '#:t)))
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2352 "checking distinct symbols with the same name are not #'equalp")
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2353 (Assert-equalp #s(char-table type generic data (?\u0080 "hi-there"))
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2354 (let ((aragh (make-char-table 'generic)))
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2355 (put-char-table ?\u0080 "hi-there" aragh)
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2356 aragh)
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2357 "checking #'equalp succeeds correctly, char-tables")
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2358 (Assert-equalp #s(char-table type generic data (?\u0080 "hi-there"))
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2359 (let ((aragh (make-char-table 'generic)))
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2360 (put-char-table ?\u0080 "HI-THERE" aragh)
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2361 aragh)
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2362 "checking #'equalp succeeds correctly, char-tables")
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2363 (Assert (not (equalp #s(char-table type generic data (?\u0080 "hi-there"))
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2364 (let ((aragh (make-char-table 'generic)))
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2365 (put-char-table ?\u0080 "hi there" aragh)
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2366 aragh)))
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API Aidan Kehoe <kehoea@parhasard.net> parents: 5188 diff changeset	2367 "checking #'equalp fails correctly, char-tables")))
4792 95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2368
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2369 ;; There are more tests available for equalp here:
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2370 ;;
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2371 ;; http://www.parhasard.net/xemacs/equalp-tests.el
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2372 ;;
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2373 ;; They are taken from Paul Dietz' GCL ANSI test suite, licensed under the
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2374 ;; LGPL and part of GNU Common Lisp; the GCL people didn't respond to
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2375 ;; several requests for information on who owned the copyright for the
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2376 ;; files, so I haven't included the tests with XEmacs. Anyone doing XEmacs
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2377 ;; development on equalp should still run them, though. Aidan Kehoe, Thu Dec
95b04754ea8c Make #'equalp more compatible with CL; add a compiler macro, test & doc it. Aidan Kehoe <kehoea@parhasard.net> parents: 4742 diff changeset	2378 ;; 31 14:53:52 GMT 2009.
4732 2491a837112c Fix typo in test of equalp and add more tests. Stephen J. Turnbull <stephen@xemacs.org> parents: 4728 diff changeset	2379
4795 084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2380 (loop
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2381 for special-form in '(multiple-value-call setq-default quote throw
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2382 save-current-buffer and or)
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2383 with not-special-form = nil
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2384 do
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2385 (Assert (special-form-p special-form)
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2386 (format "checking %S is a special operator" special-form))
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2387 (setq not-special-form
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2388 (intern (format "%s-gMAu" (symbol-name special-form))))
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2389 (Assert (not (special-form-p not-special-form))
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2390 (format "checking %S is a special operator" special-form))
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2391 (Assert (not (functionp special-form))
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2392 (format "checking %S is not a function" special-form)))
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2393
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2394 (loop
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2395 for real-function in '(find-file quote-maybe + - find-file-read-only)
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2396 do (Assert (functionp real-function)
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2397 (format "checking %S is a function" real-function)))
084056f46755 #'functionp gives nil for special forms, as in CL and GNU Emacs 23. Aidan Kehoe <kehoea@parhasard.net> parents: 4792 diff changeset	2398
4885 6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2399 ;; #'member, #'assoc tests.
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2400
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2401 (when (featurep 'bignum)
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2402 (let* ((member*-list `(0 9 342 [hi there] ,(1+ most-positive-fixnum) 0
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2403 0.0 ,(1- most-negative-fixnum) nil))
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2404 (assoc*-list (loop
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2405 for elt in member*-list
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2406 collect (cons elt (random))))
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2407 (hashing (make-hash-table :test 'eql))
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2408 hashed-bignum)
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2409 (macrolet
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2410 ((1+most-positive-fixnum ()
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2411 (1+ most-positive-fixnum))
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2412 (1-most-negative-fixnum ()
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2413 (1- most-negative-fixnum))
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2414 (*-2-most-positive-fixnum ()
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2415 (* 2 most-positive-fixnum)))
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2416 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2417 (member* (1+ most-positive-fixnum) member*-list)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2418 (member* (1+ most-positive-fixnum) member*-list :test #'eql))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2419 "checking #'member* correct if #'eql not explicitly specified")
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2420 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2421 (assoc* (1+ most-positive-fixnum) assoc*-list)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2422 (assoc* (1+ most-positive-fixnum) assoc*-list :test #'eql))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2423 "checking #'assoc* correct if #'eql not explicitly specified")
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2424 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2425 (rassoc* (1- most-negative-fixnum) assoc*-list)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2426 (rassoc* (1- most-negative-fixnum) assoc*-list :test #'eql))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2427 "checking #'rassoc* correct if #'eql not explicitly specified")
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2428 (Assert (eql (1+most-positive-fixnum) (1+ most-positive-fixnum))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2429 "checking #'eql handles a bignum literal properly.")
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2430 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2431 (member* (1+most-positive-fixnum) member*-list)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2432 (member* (1+ most-positive-fixnum) member*-list :test #'equal))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2433 "checking #'member* compiler macro correct with literal bignum")
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2434 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2435 (assoc* (1+most-positive-fixnum) assoc*-list)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2436 (assoc* (1+ most-positive-fixnum) assoc*-list :test #'equal))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2437 "checking #'assoc* compiler macro correct with literal bignum")
4885 6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2438 (puthash (setq hashed-bignum (*-2-most-positive-fixnum))
6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2439 (gensym) hashing)
5136 0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2440 (Assert (eq
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2441 (gethash (* 2 most-positive-fixnum) hashing)
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2442 (gethash hashed-bignum hashing))
0f66906b6e37 Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically Ben Wing <ben@xemacs.org> parents: 5036 diff changeset	2443 "checking hashing works correctly with #'eql tests and bignums"))))
4885 6772ce4d982b Fix hash tables, #'member, #'assoc, #'eql compiler macros if bignums Aidan Kehoe <kehoea@parhasard.net> parents: 4855 diff changeset	2444
5700 37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2445 ;; #'subsetp tests.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2446 ;; Return non-nil if every element of LIST1 also appears in LIST2.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2447 ;; A couple of non-nondegenerate false cases.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2448 (Assert (not (subsetp (list ?a ?b) (list ?c ?d))))
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2449 (Assert (not (subsetp (list ?a ?b) (list ?b ?c ?d))))
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2450 ;; Next five thanks to Steven and Benson Mitchell on XEmacs Beta
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2451 ;; <50D16FF7.4090708@bnin.net>.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2452 ;; Two non-degenerate true cases.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2453 (Assert (subsetp (list ?a) (list ?a ?b ?c ?d)))
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2454 (Assert (subsetp (list ?a ?b) (list ?a ?b ?c ?d)))
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2455 ;; The three degenerate cases involving nil.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2456 (Assert (not (subsetp (list ?a) nil)))
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2457 (Assert (subsetp nil (list ?a ?b ?c ?d)))
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2458 (Assert (subsetp nil nil))
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2459 ;; #### We should also test the keywords.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2460 ;; #### We should also test the error conditions.
37479d841681 Fix subsetp based on patch by Benson and Steven Mitchell. Stephen J. Turnbull <stephen@xemacs.org> parents: 5658 diff changeset	2461
5241 d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2462 ;;
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2463 (when (decode-char 'ucs #x0192)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2464 (Check-Error
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2465 invalid-state
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2466 (let ((str "aaaaaaaaaaaaa")
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2467 (called 0)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2468 modified)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2469 (reduce #'+ str
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2470 :key #'(lambda (object)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2471 (prog1
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2472 object
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2473 (incf called)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2474 (or modified
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2475 (and (> called 5)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2476 (setq modified
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2477 (fill str (read #r"?\u0192")))))))))))
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2478
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2479 (Assert
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2480 (eql 55
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2481 (let ((sequence '(1 2 3 4 5 6 7 8 9 10))
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2482 (called 0)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2483 modified)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2484 (reduce #'+
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2485 sequence
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2486 :key
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2487 #'(lambda (object) (prog1
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2488 object
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2489 (incf called)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2490 (and (eql called 5)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2491 (setcdr (nthcdr 3 sequence) nil))
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2492 (garbage-collect))))))
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2493 "checking we can amputate lists without crashing #'reduce")
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce Aidan Kehoe <kehoea@parhasard.net> parents: 5191 diff changeset	2494
5244 04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2495 (Assert (not (eq t (canonicalize-inst-list
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2496 `(((mswindows) . [string :data ,(make-string 20 0)])
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2497 ((tty) . [string :data " "])) 'image t)))
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2498 "checking mswindows is always available as a specifier tag")
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2499
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2500 (Assert (not (eq t (canonicalize-inst-list
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2501 `(((mswindows) . [nothing])
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2502 ((tty) . [string :data " "]))
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2503 'image t)))
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2504 "checking the correct syntax for a nothing image specifier works")
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2505
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2506 (Check-Error-Message invalid-argument "^Invalid specifier tag set"
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2507 (canonicalize-inst-list
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2508 `(((,(gensym)) . [nothing])
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2509 ((tty) . [string :data " "]))
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2510 'image))
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2511
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2512 (Check-Error-Message invalid-argument "^Unrecognized keyword"
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2513 (canonicalize-inst-list
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2514 `(((mswindows) . [nothing :data "hi there"])
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2515 ((tty) . [string :data " "])) 'image))
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2516
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2517 ;; If we combine both the specifier inst list problems, we get the
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2518 ;; unrecognized keyword error first, not the invalid specifier tag set
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2519 ;; error. This is a little unintuitive; the specifier tag set thing is
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2520 ;; processed first, and would seem to be more important. But anyone writing
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2521 ;; code needs to solve both problems, it's reasonable to ask them to do it
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2522 ;; in series rather than in parallel.
04811a268716 Be clearer in our error messages, #'canonicalize-inst-pair, #'canonicalize-spec Aidan Kehoe <kehoea@parhasard.net> parents: 5243 diff changeset	2523
5243 808131ba4a57 Print symbols with ratio-like names and the associated ratios distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5241 diff changeset	2524 (when (featurep 'ratio)
808131ba4a57 Print symbols with ratio-like names and the associated ratios distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5241 diff changeset	2525 (Assert (not (eql '1/2 (read (prin1-to-string (intern "1/2")))))
808131ba4a57 Print symbols with ratio-like names and the associated ratios distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5241 diff changeset	2526 "checking symbols with ratio-like names are printed distinctly")
808131ba4a57 Print symbols with ratio-like names and the associated ratios distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5241 diff changeset	2527 (Assert (not (eql '1/5 (read (prin1-to-string (intern "2/10")))))
808131ba4a57 Print symbols with ratio-like names and the associated ratios distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5241 diff changeset	2528 "checking symbol named \"2/10\" not eql to ratio 1/5 on read"))
808131ba4a57 Print symbols with ratio-like names and the associated ratios distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5241 diff changeset	2529
5283 be436ac36ba4 Don't share a counter when checking for circularity, list_merge(). Aidan Kehoe <kehoea@parhasard.net> parents: 5244 diff changeset	2530 (let* ((count 0)
be436ac36ba4 Don't share a counter when checking for circularity, list_merge(). Aidan Kehoe <kehoea@parhasard.net> parents: 5244 diff changeset	2531 (list (map-into (make-list 2048 nil) #'(lambda () (decf count))))
be436ac36ba4 Don't share a counter when checking for circularity, list_merge(). Aidan Kehoe <kehoea@parhasard.net> parents: 5244 diff changeset	2532 (expected (append list '(1))))
be436ac36ba4 Don't share a counter when checking for circularity, list_merge(). Aidan Kehoe <kehoea@parhasard.net> parents: 5244 diff changeset	2533 (Assert (equal expected (merge 'list list '(1) #'<))
be436ac36ba4 Don't share a counter when checking for circularity, list_merge(). Aidan Kehoe <kehoea@parhasard.net> parents: 5244 diff changeset	2534 "checking merge's circularity checks are sane"))
be436ac36ba4 Don't share a counter when checking for circularity, list_merge(). Aidan Kehoe <kehoea@parhasard.net> parents: 5244 diff changeset	2535
5576 071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2536 (labels ((list-nreverse (list)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2537 (do ((list1 list (cdr list1))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2538 (list2 nil (prog1 list1 (setcdr list1 list2))))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2539 ((atom list1) list2))))
5300 9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2540 (let* ((integers (loop for i from 0 to 6000 collect i))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2541 (characters (mapcan #'(lambda (integer)
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2542 (if (char-int-p integer)
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2543 (list (int-char integer)))) integers))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2544 (fourth-bit #'(lambda (integer) (ash (logand #x10 integer) -4)))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2545 (bits (mapcar fourth-bit integers))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2546 (vector (vconcat integers))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2547 (string (concat characters))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2548 (bit-vector (bvconcat bits)))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2549 (Assert (equal (reverse vector)
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2550 (vconcat (list-nreverse (copy-list integers)))))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2551 (Assert (eq vector (nreverse vector)))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2552 (Assert (equal vector (vconcat (list-nreverse (copy-list integers)))))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2553 (Assert (equal (reverse string)
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2554 (concat (list-nreverse (copy-list characters)))))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2555 (Assert (eq string (nreverse string)))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2556 (Assert (equal string (concat (list-nreverse (copy-list characters)))))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2557 (Assert (eq bit-vector (nreverse bit-vector)))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2558 (Assert (equal (bvconcat (list-nreverse (copy-list bits))) bit-vector))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2559 (Assert (not (equal bit-vector
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2560 (mapcar fourth-bit
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2561 (loop for i from 0 to 6000 collect i)))))))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse. Aidan Kehoe <kehoea@parhasard.net> parents: 5299 diff changeset	2562
5307 c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2563 (Check-Error wrong-type-argument (self-insert-command 'self-insert-command))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2564 (Check-Error wrong-type-argument (make-list 'make-list 'make-list))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2565 (Check-Error wrong-type-argument (make-vector 'make-vector 'make-vector))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2566 (Check-Error wrong-type-argument (make-bit-vector 'make-bit-vector
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2567 'make-bit-vector))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2568 (Check-Error wrong-type-argument (make-byte-code '(&rest ignore) "\xc0\x87" [4]
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2569 'ignore))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2570 (Check-Error wrong-type-argument (make-string ?a ?a))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2571 (Check-Error wrong-type-argument (nth-value 'nth-value (truncate pi e)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2572 (Check-Error wrong-type-argument (make-hash-table :test #'eql :size :size))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2573 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2574 (accept-process-output nil 'accept-process-output))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2575 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2576 (accept-process-output nil 2000 'accept-process-output))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2577 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2578 (self-insert-command 'self-insert-command))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2579 (Check-Error wrong-type-argument (string-to-number "16" 'string-to-number))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2580 (Check-Error wrong-type-argument (move-to-column 'move-to-column))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2581 (stop-profiling)
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2582 (Check-Error wrong-type-argument (start-profiling (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2583 (stop-profiling)
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2584 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2585 (fill '(1 2 3 4 5) 1 :start (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2586 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2587 (fill [1 2 3 4 5] 1 :start (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2588 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2589 (fill "1 2 3 4 5" ?1 :start (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2590 (Check-Error wrong-type-argument
5323 f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2591 (fill #*10101010 1 :start (float most-positive-fixnum)))
5307 c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2592 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2593 (fill '(1 2 3 4 5) 1 :end (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2594 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2595 (fill [1 2 3 4 5] 1 :end (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2596 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2597 (fill "1 2 3 4 5" ?1 :end (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2598 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2599 (fill #*10101010 1 :end (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2600 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2601 (reduce #'cons '(1 2 3 4 5) :start (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2602 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2603 (reduce #'cons [1 2 3 4 5] :start (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2604 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2605 (reduce #'cons "1 2 3 4 5" :start (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2606 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2607 (reduce #'cons #*10101010 :start (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2608 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2609 (reduce #'cons '(1 2 3 4 5) :end (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2610 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2611 (reduce #'cons [1 2 3 4 5] :end (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2612 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2613 (reduce #'cons "1 2 3 4 5" :end (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2614 (Check-Error wrong-type-argument
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2615 (reduce #'cons #*10101010 :end (float most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2616
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2617 (when (featurep 'bignum)
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2618 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2619 (self-insert-command (* 2 most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2620 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2621 (make-list (* 3 most-positive-fixnum) 'make-list))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2622 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2623 (make-vector (* 4 most-positive-fixnum) 'make-vector))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2624 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2625 (make-bit-vector (+ 2 most-positive-fixnum) 'make-bit-vector))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2626 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2627 (make-byte-code '(&rest ignore) "\xc0\x87" [4]
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2628 (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2629 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2630 (make-byte-code '(&rest ignore) "\xc0\x87" [4]
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2631 #x10000))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2632 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2633 (make-string (* 4 most-positive-fixnum) ?a))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2634 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2635 (nth-value most-positive-fixnum (truncate pi e)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2636 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2637 (make-hash-table :test #'equalp :size (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2638 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2639 (accept-process-output nil 4294967))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2640 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2641 (accept-process-output nil 10 (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2642 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2643 (self-insert-command (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2644 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2645 (string-to-number "16" (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2646 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2647 (recent-keys (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2648 (when (featurep 'xbm)
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2649 (Check-Error-Message
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2650 invalid-argument
5736 3192994c49ca Convert C (un)signed long long values to bignums properly. Jerry James <james@xemacs.org> parents: 5700 diff changeset	2651 "^Height must be a natural number"
5307 c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2652 (set-face-background-pixmap
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2653 'left-margin
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2654 `[xbm :data (20 ,(* 2 most-positive-fixnum) "random-text")])))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2655 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2656 (move-to-column (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2657 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2658 (move-to-column (1- most-negative-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2659 (stop-profiling)
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2660 (when (< most-positive-fixnum (lsh 1 32))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2661 ;; We only support machines with integers of 32 bits or more. If
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2662 ;; most-positive-fixnum is less than 2^32, we're on a 32-bit machine,
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2663 ;; and it's appropriate to test start-profiling with a bignum.
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2664 (Assert (eq nil (start-profiling (* most-positive-fixnum 2)))))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2665 (stop-profiling)
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2666 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2667 (fill '(1 2 3 4 5) 1 :start (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2668 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2669 (fill [1 2 3 4 5] 1 :start (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2670 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2671 (fill "1 2 3 4 5" ?1 :start (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2672 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2673 (fill #*10101010 1 :start (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2674 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2675 (fill '(1 2 3 4 5) 1 :end (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2676 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2677 (fill [1 2 3 4 5] 1 :end (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2678 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2679 (fill "1 2 3 4 5" ?1 :end (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2680 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2681 (fill #*10101010 1 :end (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2682 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2683 (reduce #'cons '(1 2 3 4 5) :start (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2684 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2685 (reduce #'cons [1 2 3 4 5] :start (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2686 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2687 (reduce #'cons "1 2 3 4 5" :start (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2688 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2689 (reduce #'cons #*10101010 :start (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2690 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2691 (reduce #'cons '(1 2 3 4 5) :end (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2692 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2693 (reduce #'cons [1 2 3 4 5] :end (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2694 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2695 (reduce #'cons "1 2 3 4 5" :end (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2696 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2697 (reduce #'cons #*10101010 :end (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2698 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2699 (replace '(1 2 3 4 5) [5 4 3 2 1]
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2700 :start1 (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2701 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2702 (replace '(1 2 3 4 5) [5 4 3 2 1]
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2703 :start2 (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2704 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2705 (replace '(1 2 3 4 5) [5 4 3 2 1]
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2706 :end1 (1+ most-positive-fixnum)))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2707 (Check-Error args-out-of-range
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2708 (replace '(1 2 3 4 5) [5 4 3 2 1]
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2709 :end2 (1+ most-positive-fixnum))))
c096d8051f89 Have NATNUMP give t for positive bignums; check limits appropriately. Aidan Kehoe <kehoea@parhasard.net> parents: 5300 diff changeset	2710
5323 f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2711 (symbol-macrolet
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2712 ((list-length 2048) (vector-length 512) (string-length (* 8192 2)))
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2713 (let ((list
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2714 ;; CIRCULAR_LIST_SUSPICION_LENGTH is 1024, it's helpful if this list
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2715 ;; is longer than that.
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2716 (make-list list-length 'make-list))
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2717 (vector (make-vector vector-length 'make-vector))
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2718 (bit-vector (make-bit-vector vector-length 1))
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2719 (string (make-string string-length
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2720 (or (decode-char 'ucs #x20ac) ?\xFF)))
f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2721 (item 'cons))
5347 fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2722 (macrolet
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2723 ((construct-item-sequence-checks (&rest functions)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2724 (cons
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2725 'progn
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2726 (mapcan
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2727 #'(lambda (function)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2728 `((Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2729 (,function item list
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2730 :start (1+ list-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2731 :end (1+ list-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2732 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2733 (,function item list :start -1
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2734 :end list-length))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2735 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2736 (,function item list :end (* 2 list-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2737 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2738 (,function item vector
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2739 :start (1+ vector-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2740 :end (1+ vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2741 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2742 (,function item vector :start -1))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2743 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2744 (,function item vector
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2745 :end (* 2 vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2746 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2747 (,function item bit-vector
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2748 :start (1+ vector-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2749 :end (1+ vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2750 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2751 (,function item bit-vector :start -1))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2752 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2753 (,function item bit-vector
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2754 :end (* 2 vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2755 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2756 (,function item string
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2757 :start (1+ string-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2758 :end (1+ string-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2759 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2760 (,function item string :start -1))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2761 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2762 (,function item string
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2763 :end (* 2 string-length)))))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2764 functions)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2765 (construct-one-sequence-checks (&rest functions)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2766 (cons
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2767 'progn
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2768 (mapcan
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2769 #'(lambda (function)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2770 `((Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2771 (,function (copy-sequence list)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2772 :start (1+ list-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2773 :end (1+ list-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2774 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2775 (,function (copy-sequence list)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2776 :start -1 :end list-length))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2777 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2778 (,function (copy-sequence list)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2779 :end (* 2 list-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2780 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2781 (,function (copy-sequence vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2782 :start (1+ vector-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2783 :end (1+ vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2784 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2785 (,function (copy-sequence vector) :start -1))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2786 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2787 (,function (copy-sequence vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2788 :end (* 2 vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2789 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2790 (,function (copy-sequence bit-vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2791 :start (1+ vector-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2792 :end (1+ vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2793 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2794 (,function (copy-sequence bit-vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2795 :start -1))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2796 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2797 (,function (copy-sequence bit-vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2798 :end (* 2 vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2799 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2800 (,function (copy-sequence string)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2801 :start (1+ string-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2802 :end (1+ string-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2803 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2804 (,function (copy-sequence string) :start -1))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2805 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2806 (,function (copy-sequence string)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2807 :end (* 2 string-length)))))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2808 functions)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2809 (construct-two-sequence-checks (&rest functions)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2810 (cons
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2811 'progn
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2812 (mapcan
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2813 #'(lambda (function)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2814 `((Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2815 (,function (copy-sequence list)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2816 (copy-sequence list)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2817 :start1 (1+ list-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2818 :end1 (1+ list-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2819 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2820 (,function (copy-sequence list)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2821 (copy-sequence list)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2822 :start1 -1 :end1 list-length))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2823 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2824 (,function (copy-sequence list)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2825 (copy-sequence list)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2826 :end1 (* 2 list-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2827 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2828 (,function (copy-sequence vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2829 (copy-sequence vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2830 :start1 (1+ vector-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2831 :end1 (1+ vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2832 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2833 (,function
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2834 (copy-sequence vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2835 (copy-sequence vector) :start1 -1))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2836 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2837 (,function (copy-sequence vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2838 (copy-sequence vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2839 :end1 (* 2 vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2840 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2841 (,function (copy-sequence bit-vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2842 (copy-sequence bit-vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2843 :start1 (1+ vector-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2844 :end1 (1+ vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2845 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2846 (,function (copy-sequence bit-vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2847 (copy-sequence bit-vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2848 :start1 -1))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2849 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2850 (,function (copy-sequence bit-vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2851 (copy-sequence bit-vector)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2852 :end1 (* 2 vector-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2853 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2854 (,function (copy-sequence string)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2855 (copy-sequence string)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2856 :start1 (1+ string-length)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2857 :end1 (1+ string-length)))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2858 (Check-Error wrong-type-argument
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2859 (,function (copy-sequence string)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2860 (copy-sequence string) :start1 -1))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2861 (Check-Error args-out-of-range
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2862 (,function (copy-sequence string)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2863 (copy-sequence string)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2864 :end1 (* 2 string-length)))))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2865 functions))))
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2866 (construct-item-sequence-checks count position find delete* remove*
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2867 reduce)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2868 (construct-one-sequence-checks delete-duplicates remove-duplicates)
fd441b85d760 Loop at macroexpansion time when sanity-checking :start, :end keyword args. Aidan Kehoe <kehoea@parhasard.net> parents: 5346 diff changeset	2869 (construct-two-sequence-checks replace mismatch search))))
5323 f87bb35a6b94 Test sanity-checking of :start, :end keyword arguments when appropriate. Aidan Kehoe <kehoea@parhasard.net> parents: 5307 diff changeset	2870
5336 287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2871 (let* ((list (list 1 2 3 4 5 6 7 120 'hi-there '#:everyone))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2872 (vector (map 'vector #'identity list))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2873 (bit-vector (map 'bit-vector
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2874 #'(lambda (object) (if (fixnump object) 1 0)) list))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2875 (string (map 'string
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2876 #'(lambda (object) (or (and (fixnump object)
5772 cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	2877 (int-char object))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	2878 (decode-char 'ucs #x20ac)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	2879 ?\x20))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	2880 list))
5336 287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2881 (gensym (gensym)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2882 (Assert (null (find 'not-in-it list)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2883 (Assert (null (find 'not-in-it vector)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2884 (Assert (null (find 'not-in-it bit-vector)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2885 (Assert (null (find 'not-in-it string)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2886 (loop
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2887 for elt being each element in vector using (index position)
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2888 do
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2889 (Assert (eq elt (find elt list)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2890 (Assert (eq (elt list position) (find elt vector))))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2891 (Assert (eq gensym (find 'not-in-it list :default gensym)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2892 (Assert (eq gensym (find 'not-in-it vector :default gensym)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2893 (Assert (eq gensym (find 'not-in-it bit-vector :default gensym)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2894 (Assert (eq gensym (find 'not-in-it string :default gensym)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2895 (Assert (eq 'hi-there (find 'hi-there list)))
287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2896 ;; Different uninterned symbols with the same name.
5339 ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2897 (Assert (not (eq '#1=#:everyone (find '#1# list))))
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2898
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2899 ;; Test concatenate.
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2900 (Assert (equal list (concatenate 'list vector)))
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2901 (Assert (equal list (concatenate 'list (subseq vector 0 4)
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2902 (subseq list 4))))
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2903 (Assert (equal vector (concatenate 'vector list)))
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2904 (Assert (equal vector (concatenate `(vector * ,(length vector)) list)))
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2905 (Assert (equal string (concatenate `(vector character ,(length string))
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2906 (append string nil))))
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2907 (Assert (equal bit-vector (concatenate 'bit-vector (subseq bit-vector 0 4)
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2908 (append (subseq bit-vector 4) nil))))
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2909 (Assert (equal bit-vector (concatenate `(vector bit ,(length bit-vector))
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2910 (subseq bit-vector 0 4)
ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5336 diff changeset	2911 (append (subseq bit-vector 4) nil)))))
5336 287499ff4c5f Pass in the DEFAULT argument to position() as documented, #'find. Aidan Kehoe <kehoea@parhasard.net> parents: 5329 diff changeset	2912
5353 38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2913 ;;-----------------------------------------------------
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2914 ;; Test `block', `return-from'
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2915 ;;-----------------------------------------------------
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2916 (Assert (eql 1 (block outer
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2917 (flet ((outtahere (n) (return-from outer n)))
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2918 (block outer (outtahere 1)))
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2919 2))
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2920 "checking `block' and `return-from' are lexically scoped correctly")
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2921
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2922 ;; Other tests are available in Paul Dietz' test suite, and pass. The above,
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2923 ;; which we used to fail, is based on a test in the Hyperspec. We still
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2924 ;; behave incorrectly when compiled for the contorted-example function of
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2925 ;; CLTL2, whence the following test:
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2926
5576 071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2927 (labels ((needs-lexical-context (first second third)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2928 (if (eql 0 first)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2929 (funcall second)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2930 (block awkward
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2931 (+ 5 (needs-lexical-context
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2932 (1- first)
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2933 third
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2934 #'(lambda () (return-from awkward 0)))
071b810ceb18 Declare labels as line where appropriate; use #'labels, not #'flet, tests. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	2935 first)))))
5595 391d809fa4e9 Update tests that have started failing because of changed design decisions. Aidan Kehoe <kehoea@parhasard.net> parents: 5576 diff changeset	2936 (Known-Bug-Expect-Failure
391d809fa4e9 Update tests that have started failing because of changed design decisions. Aidan Kehoe <kehoea@parhasard.net> parents: 5576 diff changeset	2937 (Assert (eql 0 (needs-lexical-context 2 nil nil))
391d809fa4e9 Update tests that have started failing because of changed design decisions. Aidan Kehoe <kehoea@parhasard.net> parents: 5576 diff changeset	2938 "the function special operator doesn't create a lexical context.")))
5353 38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5347 diff changeset	2939
5642 5bda701e9e7c Be more careful about non-quoted-symbol TAGs, #'byte-compile-catch Aidan Kehoe <kehoea@parhasard.net> parents: 5595 diff changeset	2940 (Assert (eql 10 (catch ':keyword (+ (catch :keyword (throw :keyword 9)) 1)))
5bda701e9e7c Be more careful about non-quoted-symbol TAGs, #'byte-compile-catch Aidan Kehoe <kehoea@parhasard.net> parents: 5595 diff changeset	2941 "checking `byte-compile-catch' doesn't strip keyword TAGs")
5bda701e9e7c Be more careful about non-quoted-symbol TAGs, #'byte-compile-catch Aidan Kehoe <kehoea@parhasard.net> parents: 5595 diff changeset	2942
5462 97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2943 ;; Test symbol-macrolet with symbols with identical string names.
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2944
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2945 (macrolet
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2946 ((test-symbol-macrolet ()
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2947 (let* ((symbol 'my-symbol)
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2948 (copy-symbol (copy-symbol symbol))
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2949 (third (copy-symbol copy-symbol)))
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2950 `(symbol-macrolet ((,symbol [symbol expansion])
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2951 (,copy-symbol [copy expansion])
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2952 (,third [third expansion]))
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2953 (list ,symbol ,copy-symbol ,third)))))
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2954 (Assert (equal '([symbol expansion] [copy expansion] [third expansion])
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2955 (test-symbol-macrolet))))
97ac18bd1fa3 Make sure distinct symbol macros with identical names expand distinctly. Aidan Kehoe <kehoea@parhasard.net> parents: 5374 diff changeset	2956
5550 b908c7265a2b Add the #'apply-partially API, as used by GNU. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	2957 ;; Basic tests of #'apply-partially.
b908c7265a2b Add the #'apply-partially API, as used by GNU. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	2958 (let* ((four 4)
b908c7265a2b Add the #'apply-partially API, as used by GNU. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	2959 (times-four (apply-partially '* four))
5553 62edcc6a11ec Add an assertion about argument order to #'apply-partially compiler macro Aidan Kehoe <kehoea@parhasard.net> parents: 5550 diff changeset	2960 (plus-twelve (apply-partially '+ 6 (* 3 2)))
62edcc6a11ec Add an assertion about argument order to #'apply-partially compiler macro Aidan Kehoe <kehoea@parhasard.net> parents: 5550 diff changeset	2961 (construct-list (apply-partially 'list (incf four) (incf four)
5737 165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2962 (incf four)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2963 (list-and-multiply
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2964 (apply-partially #'(lambda (a b c d &optional e)
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2965 (cons (apply #'+ a b c d (if e (list e)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2966 (list* a b c d e)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2967 ;; Constant arguments -> function can be
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2968 ;; constructed at compile time
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2969 1 2 3))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2970 (list-and-four
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2971 (apply-partially #'(lambda (a b c d &optional e)
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2972 (cons (apply #'+ a b c d (if e (list e)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2973 (list* a b c d e)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2974 ;; Not constant arguments -> function constructed
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2975 ;; at runtime.
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2976 1 2 four)))
5550 b908c7265a2b Add the #'apply-partially API, as used by GNU. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	2977 (Assert (eql (funcall times-four 6) 24))
b908c7265a2b Add the #'apply-partially API, as used by GNU. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	2978 (Assert (eql (funcall times-four 4 4) 64))
b908c7265a2b Add the #'apply-partially API, as used by GNU. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	2979 (Assert (eql (funcall plus-twelve (funcall times-four 4) 4 4) 36))
5553 62edcc6a11ec Add an assertion about argument order to #'apply-partially compiler macro Aidan Kehoe <kehoea@parhasard.net> parents: 5550 diff changeset	2980 (Check-Error wrong-number-of-arguments (apply-partially))
5737 165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2981 (Assert (equal (funcall construct-list) '(5 6 7)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2982 (Assert (equal (funcall list-and-multiply 5 6) '(17 1 2 3 5 . 6)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2983 (Assert (equal (funcall list-and-multiply 7) '(13 1 2 3 7)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2984 (Check-Error wrong-number-of-arguments
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2985 (funcall list-and-multiply 7 8 9 10))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2986 (Assert (equal (funcall list-and-four 5 6) '(21 1 2 7 5 . 6)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2987 (Assert (equal (funcall list-and-four 7) '(17 1 2 7 7)))
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2988 (Check-Error wrong-number-of-arguments
165315eae1ab Make #'apply-partially more intelligent still when byte-compiled. Aidan Kehoe <kehoea@parhasard.net> parents: 5736 diff changeset	2989 (funcall list-and-four 7 8 9 10)))
5550 b908c7265a2b Add the #'apply-partially API, as used by GNU. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	2990
5852 e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	2991 ;; 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	2992
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	2993 (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	2994 (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	2995 '(a b c d e a f g)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	2996
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	2997 (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	2998 (x (copy-list nomodif))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	2999 (y (substitute 'z 'a x)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3000 (and (equal nomodif x) y))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3001 '(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	3002 (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	3003 (x (copy-list nomodif))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3004 (y (substitute 'z 'a x :count nil)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3005 (and (equal nomodif x) y))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3006 '(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	3007 (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	3008 (x (copy-list nomodif))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3009 (y (substitute 'z 'a x :key nil)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3010 (and (equal nomodif x) y))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3011 '(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	3012 (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	3013 (x (copy-list nomodif))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3014 (y (substitute 'z 'a x :count 100)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3015 (and (equal nomodif x) y))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3016 '(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	3017 (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	3018 (x (copy-list nomodif))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3019 (y (substitute 'z 'a x :count 0)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3020 (and (equal nomodif x) y))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3021 '(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	3022 (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	3023 (x (copy-list nomodif))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3024 (y (substitute 'z 'a x :count 1)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3025 (and (equal nomodif x) y))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3026 '(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	3027 (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	3028 (x (copy-list nomodif))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3029 (y (substitute 'z 'c x :count 1)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3030 (and (equal nomodif x) y))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3031 '(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	3032 (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	3033 (x (copy-list nomodif))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3034 (y (substitute 'z 'a x :from-end t)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3035 (and (equal nomodif x) y))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3036 '(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	3037 (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	3038 (x (copy-list nomodif))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3039 (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	3040 (and (equal nomodif x) y))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3041 '(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	3042 (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	3043 (x (copy-list nomodif))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3044 (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	3045 (and (equal nomodif x) y))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3046 '(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	3047 (Assert (equal (multiple-value-list
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3048 (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	3049 (x (copy-list nomodif)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3050 (values
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3051 (loop for i from 0 to 10
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3052 collect (substitute 'z 'a x :start i))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3053 (equal nomodif x))))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3054 '(((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	3055 (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	3056 (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	3057 (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	3058 (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	3059 (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	3060 t)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3061 (Assert (equal (multiple-value-list
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3062 (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	3063 (x (copy-list nomodif)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3064 (values
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3065 (loop for i from 0 to 10
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3066 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	3067 (equal nomodif x))))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3068 '(((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	3069 (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	3070 (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	3071 (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	3072 (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	3073 (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	3074 t)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3075 (Assert (equal
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3076 (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	3077 (x (copy-list nomodif))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3078 (y (substitute 300 1 x :key #'1-)))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3079 (and (equal nomodif x) y))
e9bb3688e654 Fix some bugs in #'substitute, #'nsubstitute. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3080 '(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	3081
5574 d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3082 ;; Test labels and inlining.
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3083 (labels
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3084 ((+ (&rest arguments)
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3085 ;; Shades of Java, hah.
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3086 (mapconcat #'prin1-to-string arguments ", "))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3087 (print-with-commas (stream one two three four five)
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3088 (princ (+ one two three four five) stream))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3089 (bookend (open close &rest arguments)
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3090 (refer-to-bookend (concat open (apply #'+ arguments) close)))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3091 (refer-to-bookend (string)
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3092 (bookend "[" "]" string "hello" "there")))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3093 (declare (inline + print-with-commas bookend refer-to-bookend))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3094 (macrolet
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3095 ((with-first-arguments (&optional form)
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3096 (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	3097 (with-second-arguments (&optional form)
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3098 (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	3099 (with-both-arguments (&optional form &environment env)
5574 d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3100 (append form
5658 289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3101 (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	3102 (macroexpand '(with-second-arguments) env))))
5574 d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3103
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3104 (with-temp-buffer
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3105 (Assert
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3106 (equal
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3107 (mapconcat #'prin1-to-string (with-first-arguments (list)) ", ")
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3108 (with-first-arguments (print-with-commas (current-buffer))))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3109 "checking print-with-commas gives the expected result")
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3110 (Assert
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3111 (or
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3112 (not (compiled-function-p (indirect-function #'print-with-commas)))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3113 (notany #'compiled-function-p
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3114 (compiled-function-constants
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3115 (indirect-function #'print-with-commas))))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3116 "checking the label + was inlined correctly")
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3117 (insert ", ")
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3118 ;; 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	3119 ;; no easy way for us to check that:
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3120 (Assert (null (insert (with-second-arguments (+)))))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3121 (Assert (equal
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3122 (mapconcat #'prin1-to-string (with-both-arguments (list)) ", ")
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3123 (buffer-string))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3124 "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	3125 (Assert (not (funcall (intern "eq") #'bookend #'refer-to-bookend))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3126 "checking two mutually recursive functions compiled OK"))))
d4f334808463 Support inlining labels, bytecomp.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5560 diff changeset	3127
5658 289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3128 ;; 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	3129 ;; 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	3130
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3131 (Check-Error
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3132 void-variable
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3133 (macrolet
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3134 ((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	3135 (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	3136 (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	3137 (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	3138 (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	3139 (append form
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3140 (macroexpand '(with-first-arguments))
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3141 (macroexpand '(with-second-arguments)))))
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3142 (with-both-arguments (list))))
289cf21be887 Don't augment ENVIRONMENT when that's not indicated, #'macroexpand. Aidan Kehoe <kehoea@parhasard.net> parents: 5642 diff changeset	3143
5769 ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3144 ;; 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	3145 ;; 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	3146 (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	3147 (translation (make-char-table 'generic))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3148 markers fixnums)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3149 (macrolet
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3150 ((Assert-arith-equivalences (markers context)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3151 `(progn
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3152 (Assert (apply #'> markers)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3153 ,(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	3154 context))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3155 (Assert 0 ,context)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3156 (Assert (apply #'< (reverse markers))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3157 ,(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	3158 context))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3159 (map-plist #'(lambda (object1 object2)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3160 (Assert (> object1 object2)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3161 ,(concat
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3162 "checking markers correctly ordered, >, "
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3163 context))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3164 (Assert (< object2 object1)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3165 ,(concat
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3166 "checking markers correctly ordered, <, "
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3167 context)))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3168 markers)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3169 ;; 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	3170 ;; 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	3171 (map-plist #'(lambda (object1 object2)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3172 (Assert
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3173 (= (max object1 object2) object1)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3174 ,(concat
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3175 "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	3176 (Assert
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3177 (= (min object1 object2) object2)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3178 ,(concat
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3179 "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	3180 ;; 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	3181 ;; decision.
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3182 (Assert
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3183 (fixnump (max object1 object2))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3184 ,(concat
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3185 "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	3186 context))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3187 (Assert
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3188 (fixnump (min object1 object2))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3189 ,(concat
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3190 "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	3191 context)))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3192 markers))))
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3193 (with-temp-buffer
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3194 (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	3195 do (progn
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3196 (insert " " character " " character " " character " "
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3197 character "\n")
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3198 (insert character)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3199 (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	3200 (insert ?\x20)
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3201 (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	3202 (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	3203 ;; 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	3204 (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	3205 ;; 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	3206 ;; have them:
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3207 (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	3208 ;; 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	3209 ;; check our equivalences still hold.
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3210 (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	3211 (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	3212 ;; 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	3213 ;; deletion code do this?!
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3214 (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	3215 (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	3216 ;; Restore the problematic character.
ffc0c5a66ab1 Be lazy converting markers to integers, bytecode_{arithcompare,arithop}(). Aidan Kehoe <kehoea@parhasard.net> parents: 5737 diff changeset	3217 (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	3218 (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	3219 (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	3220 (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	3221
5772 cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3222 ;;-----------------------------------------------------
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3223 ;; 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	3224 ;;-----------------------------------------------------
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3225
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3226 (macrolet
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3227 ((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	3228 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	3229 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	3230 "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	3231 (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	3232 (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	3233 (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	3234 (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	3235 (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	3236 (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	3237 (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	3238 (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	3239 `(progn
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3240 (,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	3241 (,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	3242 (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	3243 (,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	3244 ,(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	3245 ,(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	3246 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	3247 ,@(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	3248 `((,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	3249 (,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	3250 (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	3251 (,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	3252 ,(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	3253 ,(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	3254 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	3255 (,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	3256 (,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	3257 (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	3258 (,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	3259 ,(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	3260 ,(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	3261 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	3262 (,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	3263 (,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	3264 (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	3265 (,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	3266 ,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	3267 ,(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	3268 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3269 "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	3270 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	3271 (,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	3272 (,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	3273 (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	3274 (,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	3275 ,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	3276 ,(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	3277 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3278 "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	3279 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	3280 ,(cons
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3281 'progn
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3282 (loop
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3283 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	3284 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	3285 (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	3286 nconc
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3287 `((,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	3288 (,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	3289 :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	3290 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3291 (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	3292 (,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	3293 ,(- 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	3294 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3295 "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	3296 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	3297 ,@(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	3298 `((,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	3299 (,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	3300 :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	3301 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3302 (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	3303 (,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	3304 ,(- 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	3305 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3306 "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	3307 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	3308 (,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	3309 (,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	3310 :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	3311 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3312 (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	3313 (,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	3314 ,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	3315 ,(- 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	3316 ,(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	3317 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	3318 (,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	3319 (,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	3320 :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	3321 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3322 (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	3323 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	3324 (,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	3325 ,(- 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	3326 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3327 "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	3328 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	3329 ,(cons
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3330 'progn
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3331 (loop
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3332 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	3333 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	3334 (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	3335 nconc
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3336 `((,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	3337 (,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	3338 :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	3339 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3340 (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	3341 (,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	3342 ,(- 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	3343 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3344 "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	3345 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	3346 ,@(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	3347 `((,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	3348 (,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	3349 :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	3350 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3351 (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	3352 (,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	3353 ,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	3354 ,(- 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	3355 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3356 "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	3357 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	3358 (,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	3359 (,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	3360 :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	3361 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3362 (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	3363 (,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	3364 ,(- 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	3365 ,(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	3366 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	3367 (,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	3368 (,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	3369 :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	3370 (Assert
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3371 (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	3372 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	3373 (,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	3374 ,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	3375 ,(- 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	3376 ,(format
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3377 "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	3378 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	3379 (,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	3380 (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	3381 (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	3382 (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	3383 (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	3384 (concat
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3385 "\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	3386 "\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	3387 "\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	3388 "\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	3389 "\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	3390 "\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	3391 "\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	3392 "\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	3393 "\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	3394 "\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	3395 "\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	3396 (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	3397 (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	3398 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	3399 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	3400 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	3401 `(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	3402 (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	3403 (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	3404 (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	3405 (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	3406 (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	3407 (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	3408 #'(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	3409 (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	3410 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	3411 (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	3412 (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	3413 (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	3414 (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	3415 (marker
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3416 (progn
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3417 (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	3418 (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	3419 (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	3420 (labels
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3421 ((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	3422 (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	3423 buffer))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3424 (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	3425 (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	3426 (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	3427 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	3428 (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	3429 (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	3430 (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	3431 (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	3432 (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	3433 (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	3434 (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	3435 (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	3436 (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	3437 (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	3438 length)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3439 (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	3440 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	3441 (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	3442 (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	3443 (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	3444 (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	3445 (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	3446 (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	3447 (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	3448 (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	3449 (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	3450 (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	3451 (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	3452 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	3453 (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	3454 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	3455 (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	3456 (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	3457 (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	3458 (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	3459 (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	3460 (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	3461 (,(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	3462 'progn
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3463 '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	3464 (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	3465 (,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	3466 (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	3467 (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	3468 (,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	3469 (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	3470 :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	3471 (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	3472 (,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	3473 (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	3474 :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	3475 (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	3476 ,@(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	3477 `((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	3478 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	3479 (,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	3480 (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	3481 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	3482 (,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	3483 ,@(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	3484 `((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	3485 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	3486 (,function
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3487 (vector
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3488 (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	3489 (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	3490 `((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	3491 (,function
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3492 ',(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	3493 (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	3494 (,function
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3495 ,(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	3496 (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	3497 (,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	3498 (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	3499 (,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	3500 :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	3501 (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	3502 (,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	3503 :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	3504 (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	3505 (,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	3506 (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	3507 (,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	3508 :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	3509 (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	3510 (,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	3511 :start
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5771 diff changeset	3512 ,(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	3513 ;; 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	3514 ;; 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	3515 (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	3516 ,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	3517 :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	3518 :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	3519 :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	3520 :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	3521 ,(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	3522 '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	3523 (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	3524 ,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	3525 :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	3526 :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	3527 :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	3528 :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	3529 ,(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	3530 '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	3531 '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	3532 (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	3533 ,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	3534 :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	3535 :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	3536 :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	3537 '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	3538 '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	3539 (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	3540 (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	3541 (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	3542 (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	3543 (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	3544
5864 750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3545 ;;-----------------------------------------------------
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3546 ;; 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	3547 ;;-----------------------------------------------------
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3548
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3549 (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	3550
5864 750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3551 (if (featurep 'bignum)
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3552 (progn
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3553 (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	3554 (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	3555 (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	3556 (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	3557 (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	3558 (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	3559 (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	3560 (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	3561
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3562 (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	3563 (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	3564 (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	3565 (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	3566 (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	3567 (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	3568 (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	3569 (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	3570 (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	3571 (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	3572
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3573 (macrolet
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3574 ((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	3575 (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	3576 (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	3577 (list*
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3578 'progn
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3579 (cons
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3580 'progn
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3581 (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	3582 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	3583 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	3584 ,(- 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	3585 ,(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	3586 script))))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3587 (sublis
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3588 tree-alist
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3589 '((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	3590 (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	3591 '(-123 7)))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3592 (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	3593 (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	3594 :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	3595 '(-1007 4)))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3596 (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	3597 (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	3598 '(3833 5)))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3599 (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	3600 (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	3601 :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	3602 '(342391 8)))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3603 (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	3604 (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	3605 '(nil 0)))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3606 (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	3607 (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	3608 '(nil 0)))
5886 c96000075e49 Be more careful about C integer overflow, #'parse-integer. Aidan Kehoe <kehoea@parhasard.net> parents: 5867 diff changeset	3609 (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	3610 :radix 16))
c96000075e49 Be more careful about C integer overflow, #'parse-integer. Aidan Kehoe <kehoea@parhasard.net> parents: 5867 diff changeset	3611 (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	3612 "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	3613 (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	3614 :radix 16))
c96000075e49 Be more careful about C integer overflow, #'parse-integer. Aidan Kehoe <kehoea@parhasard.net> parents: 5867 diff changeset	3615 (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	3616 "checking an overflow bug has been fixed, negative int")
5867 e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3617 (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	3618 :radix 8))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3619 (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	3620 (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	3621
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3622 ;; 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	3623 ;; 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	3624 (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	3625 (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	3626 "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	3627 (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	3628 (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	3629 '(nil 0))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3630 "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	3631 :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	3632 ;; 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	3633 ;; 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	3634 ;; 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	3635 (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	3636 (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	3637 (concatenate 'string
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3638 (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	3639 (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	3640 t))))))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3641 (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	3642 (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	3643 (cons
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3644 'progn
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3645 (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	3646 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	3647 (#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	3648 (#x07c0 . "Nko")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3649 (#x0966 . "Devanagari")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3650 (#x09e6 . "Bengali")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3651 (#x0a66 . "Gurmukhi")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3652 (#x0ae6 . "Gujarati")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3653 (#x0b66 . "Oriya")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3654 (#x0be6 . "Tamil")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3655 (#x0c66 . "Telugu")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3656 (#x0ce6 . "Kannada")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3657 (#x0d66 . "Malayalam")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3658 (#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	3659 (#x0e50 . "Thai")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3660 (#x0ed0 . "Lao")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3661 (#x0f20 . "Tibetan")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3662 (#x1040 . "Myanmar")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3663 (#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	3664 (#x17e0 . "Khmer")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3665 (#x1810 . "Mongolian")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3666 (#x1946 . "Limbu")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3667 (#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	3668 (#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	3669 (#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	3670 (#x1b50 . "Balinese")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3671 (#x1bb0 . "Sundanese")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3672 (#x1c40 . "Lepcha")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3673 (#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	3674 (#xa620 . "Vai")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3675 (#xa8d0 . "Saurashtra")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3676 (#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	3677 (#xa9d0 . "Javanese")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3678 (#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	3679 (#xaa50 . "Cham")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3680 (#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	3681 (#xff10 . "Fullwidth")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3682 (#x000104a0 . "Osmanya")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3683 (#x00011066 . "Brahmi")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3684 (#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	3685 (#x00011136 . "Chakma")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3686 (#x000111d0 . "Sharada")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3687 (#x000112f0 . "Khudawadi")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3688 (#x000114d0 . "Tirhuta")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3689 (#x00011650 . "Modi")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3690 (#x000116c0 . "Takri")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3691 (#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	3692 (#x00016a60 . "Mro")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3693 (#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	3694 (#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	3695 (#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	3696 (#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	3697 (#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	3698 (#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	3699 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	3700 ;; 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	3701 ;; 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	3702 ;; 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	3703 ,(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	3704 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	3705 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	3706 "")
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3707 ,script))))))
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3708 (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	3709 (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	3710
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3711 ;; 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	3712 (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	3713 (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	3714 (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	3715 (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	3716 (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	3717 (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	3718
5867 e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3719 (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	3720 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	3721
5867 e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3722 (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	3723 (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	3724 (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	3725 (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	3726 (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	3727 (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	3728 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	3729 (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	3730 (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	3731 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	3732 nil)
e0f1dfaa821e Add the non-ASCII digit support, now #'parse-integer can handle it. Aidan Kehoe <kehoea@parhasard.net> parents: 5865 diff changeset	3733 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	3734 (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	3735 (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	3736 (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	3737 (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	3738
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3739 (let ((binary-table
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3740 (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	3741 (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	3742 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	3743 (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	3744 (parse-integer
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3745 (concatenate 'string "\x3f"
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3746 (make-string
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3747 (/ (- (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	3748 (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	3749 ?\xff))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3750 :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	3751 "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	3752 (Assert (equal
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3753 (multiple-value-list
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3754 (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	3755 '(1717 6))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3756 "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	3757 (Assert (equal
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3758 (multiple-value-list
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3759 (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	3760 :junk-allowed t))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3761 '(1717 5))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3762 "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	3763 (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	3764 (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	3765 (Assert (equal
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3766 (multiple-value-list
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3767 (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	3768 '(-45 2))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3769 "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	3770 (Assert (equal
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3771 (multiple-value-list
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3772 (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	3773 '(2830896 3))
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3774 "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	3775 (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	3776 "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	3777 (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	3778 "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	3779 (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	3780 #x20)
750fab17b299 Make #'parse-integer Lisp-visible, extend it, allowing non-ASCII digits. Aidan Kehoe <kehoea@parhasard.net> parents: 5772 diff changeset	3781 "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	3782 (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	3783 "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	3784 (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	3785 "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	3786 (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	3787 "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	3788 (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	3789 "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	3790 (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	3791 "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	3792 (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	3793 "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	3794 (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	3795 "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	3796 (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	3797 "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	3798
5891 a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3799 ;; 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	3800
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3801 (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	3802 (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	3803 (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	3804 (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	3805
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3806 (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	3807 "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	3808 (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	3809 (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	3810 (concat
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3811 "\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	3812 "\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	3813 "\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	3814 "\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	3815 'utf-8))))
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3816 (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	3817 (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	3818 (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	3819 (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	3820 (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	3821 (length string))))
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3822 (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	3823 (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	3824 string))))
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3825
a0e751d6c3ad Import the #'clear-string API from GNU, use it in tls.c Aidan Kehoe <kehoea@parhasard.net> parents: 5886 diff changeset	3826 ;; 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	3827
4732 2491a837112c Fix typo in test of equalp and add more tests. Stephen J. Turnbull <stephen@xemacs.org> parents: 4728 diff changeset	3828 ;;; end of lisp-tests.el

Mercurial > hg > xemacs-beta

annotate tests/automated/lisp-tests.el @ 5891:a0e751d6c3ad