xemacs-beta: lisp/cl-extra.el annotate

annotate lisp/cl-extra.el @ 5940:c608d4b0b75e cygwin64 tip

rescue lost branch from 64bit.backup

author	Henry Thompson <ht@markup.co.uk>
date	Thu, 16 Dec 2021 18:48:58 +0000
parents	cd4f5f1f1f4c
children	750fab17b299

rev	line source
613 023b83f4e54b [xemacs-hg @ 2001-06-10 10:42:16 by ben] ben parents: 502 diff changeset	1 ;;; cl-extra.el --- Common Lisp extensions for XEmacs Lisp (part two)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	2
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	3 ;; Copyright (C) 1993,2000,2003 Free Software Foundation, Inc.
801 2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben] ben parents: 776 diff changeset	4 ;; Copyright (C) 2002 Ben Wing.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	5
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	6 ;; Author: Dave Gillespie <daveg@synaptics.com>
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	7 ;; Maintainer: XEmacs Development Team
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	8 ;; Version: 2.02
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	9 ;; Keywords: extensions, dumped
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	10
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	11 ;; This file is part of XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	12
5402 308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5273 diff changeset	13 ;; 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: 5273 diff changeset	14 ;; 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: 5273 diff changeset	15 ;; 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: 5273 diff changeset	16 ;; option) any later version.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	17
5402 308d34e9f07d Changed bulk of GPLv2 or later files identified by script Mats Lidell <matsl@xemacs.org> parents: 5273 diff changeset	18 ;; 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: 5273 diff changeset	19 ;; 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: 5273 diff changeset	20 ;; 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: 5273 diff changeset	21 ;; for more details.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	22
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	23 ;; 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: 5273 diff changeset	24 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	25
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	26 ;;; Synched up with: FSF 21.3.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	27
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	28 ;;; Commentary:
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	29
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	30 ;; This file is dumped with XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	31
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	32 ;; These are extensions to Emacs Lisp that provide a degree of
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	33 ;; Common Lisp compatibility, beyond what is already built-in
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	34 ;; in Emacs Lisp.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	35 ;;
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	36 ;; This package was written by Dave Gillespie; it is a complete
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	37 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	38 ;;
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	39 ;; Bug reports, comments, and suggestions are welcome!
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	40
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	41 ;; This file contains portions of the Common Lisp extensions
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	42 ;; package which are autoloaded since they are relatively obscure.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	43
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	44 ;; See cl.el for Change Log.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	45
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	46
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	47 ;;; Code:
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	48 ;; XEmacs addition
5632 bd80d9103fc8 Integrate CL code better into core, remove obsolete compatibility code. Aidan Kehoe <kehoea@parhasard.net> parents: 5583 diff changeset	49 (eval-when-compile (require 'obsolete))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	50
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	51 ;;; Type coercion.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	52
5305 09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	53 (defun coerce (object type)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	54 "Coerce OBJECT to type TYPE.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	55 TYPE is a Common Lisp type specifier."
5305 09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	56 (cond ((eq type 'list) (if (listp object) object (append object nil)))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	57 ((eq type 'vector) (if (vectorp object) object (vconcat object)))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	58 ((eq type 'string) (if (stringp object) object (concat object)))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	59 ((eq type 'array) (if (arrayp object) object (vconcat object)))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	60 ((and (eq type 'character) (stringp object)
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	61 (eql (length object) 1)) (aref object 0))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	62 ((and (eq type 'character) (symbolp object))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	63 (coerce (symbol-name object) type))
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	64 ;; XEmacs addition character <-> integer coercions
5305 09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	65 ((and (eq type 'character) (char-int-p object)) (int-char object))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	66 ((and (memq type '(integer fixnum)) (characterp object))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	67 (char-int object))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	68 ((eq type 'float) (float object))
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	69 ;; XEmacs addition: enhanced numeric type coercions
2367 ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben] ben parents: 2153 diff changeset	70 ((and-fboundp 'coerce-number
5257 30bf66dd3ca0 Add fixnum as an accepted destination type, #'coerce Aidan Kehoe <kehoea@parhasard.net> parents: 5242 diff changeset	71 (memq type '(integer ratio bigfloat fixnum))
5305 09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	72 (coerce-number object type)))
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	73 ;; XEmacs addition: bit-vector coercion
4995 8431b52e43b1 Move the various map* functions to C; add #'map-into. Aidan Kehoe <kehoea@parhasard.net> parents: 4800 diff changeset	74 ((or (eq type 'bit-vector)
8431b52e43b1 Move the various map* functions to C; add #'map-into. Aidan Kehoe <kehoea@parhasard.net> parents: 4800 diff changeset	75 (eq type 'simple-bit-vector))
5305 09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	76 (if (bit-vector-p object)
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	77 object
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	78 (apply 'bit-vector (append object nil))))
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	79 ;; XEmacs addition: weak-list coercion
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	80 ((eq type 'weak-list)
5305 09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	81 (if (weak-list-p object) object
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	82 (let ((wl (make-weak-list)))
5305 09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	83 (set-weak-list-list wl (if (listp object)
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	84 object
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	85 (append object nil)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	86 wl)))
4995 8431b52e43b1 Move the various map* functions to C; add #'map-into. Aidan Kehoe <kehoea@parhasard.net> parents: 4800 diff changeset	87 ((and
5305 09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	88 (memq (car-safe type) '(vector simple-array))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	89 (loop
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	90 for (ignore elements length) = type
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	91 initially (declare (special ignore))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	92 return (if (or (memq length '(* nil)) (eql length (length object)))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	93 (cond
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	94 ((memq elements '(t * nil))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	95 (coerce object 'vector))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	96 ((memq elements '(string-char character))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	97 (coerce object 'string))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	98 ((eq elements 'bit)
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	99 (coerce object 'bit-vector)))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	100 (error
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	101 'wrong-type-argument
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	102 "Type specifier length must equal sequence length"
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	103 type)))))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	104 ((eq (car-safe type) 'simple-vector)
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	105 (coerce object (list* 'vector t (cdr type))))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	106 ((memq (car-safe type)
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	107 '(string simple-string base-string simple-base-string))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	108 (coerce object (list* 'vector 'character (cdr type))))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	109 ((eq (car-safe type) 'bit-vector)
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	110 (coerce object (list* 'vector 'bit (cdr type))))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	111 ((typep object type) object)
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	112 (t (error 'invalid-operation
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	113 "Can't coerce object to type" object type))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	114
5219 2d0937dc83cf Tidying of CL files; make docstrings read better, remove commented-out code Aidan Kehoe <kehoea@parhasard.net> parents: 5162 diff changeset	115 ;; XEmacs; #'equalp is in C.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	116
4997 8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX. Aidan Kehoe <kehoea@parhasard.net> parents: 4996 diff changeset	117 ;; XEmacs; #'map, #'mapc, #'mapl, #'maplist, #'mapcon, #'some and #'every
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX. Aidan Kehoe <kehoea@parhasard.net> parents: 4996 diff changeset	118 ;; are now in C, together with #'map-into, which was never in this file.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	119
5226 7789ae555c45 Add Common Lisp's #'complement to cl-extra.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5219 diff changeset	120 ;; The compiler macro for this in cl-macs.el means if #'complement is handed
7789ae555c45 Add Common Lisp's #'complement to cl-extra.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5219 diff changeset	121 ;; a constant expression, byte-compiled code will see a byte-compiled
7789ae555c45 Add Common Lisp's #'complement to cl-extra.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5219 diff changeset	122 ;; function.
7789ae555c45 Add Common Lisp's #'complement to cl-extra.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5219 diff changeset	123 (defun complement (function &optional documentation)
7789ae555c45 Add Common Lisp's #'complement to cl-extra.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5219 diff changeset	124 "Return a function which gives the logical inverse of what FUNCTION would."
7789ae555c45 Add Common Lisp's #'complement to cl-extra.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5219 diff changeset	125 `(lambda (&rest arguments) ,@(if documentation (list documentation))
7789ae555c45 Add Common Lisp's #'complement to cl-extra.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5219 diff changeset	126 (not (apply ',function arguments))))
7789ae555c45 Add Common Lisp's #'complement to cl-extra.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5219 diff changeset	127
5312 f6471e4ae703 Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery. Aidan Kehoe <kehoea@parhasard.net> parents: 5305 diff changeset	128 (defun notany (cl-predicate cl-seq &rest cl-rest)
f6471e4ae703 Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery. Aidan Kehoe <kehoea@parhasard.net> parents: 5305 diff changeset	129 "Return true if PREDICATE is false of every element of SEQUENCE.
f6471e4ae703 Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery. Aidan Kehoe <kehoea@parhasard.net> parents: 5305 diff changeset	130
f6471e4ae703 Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery. Aidan Kehoe <kehoea@parhasard.net> parents: 5305 diff changeset	131 With optional SEQUENCES, call PREDICATE each time with as many arguments as
f6471e4ae703 Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery. Aidan Kehoe <kehoea@parhasard.net> parents: 5305 diff changeset	132 there are SEQUENCES (plus one for the element from SEQUENCE).
f6471e4ae703 Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery. Aidan Kehoe <kehoea@parhasard.net> parents: 5305 diff changeset	133
f6471e4ae703 Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery. Aidan Kehoe <kehoea@parhasard.net> parents: 5305 diff changeset	134 arguments: (PREDICATE SEQUENCES &rest SEQUENCES)"
f6471e4ae703 Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery. Aidan Kehoe <kehoea@parhasard.net> parents: 5305 diff changeset	135 (not (apply 'some cl-predicate cl-seq cl-rest)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	136
5312 f6471e4ae703 Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery. Aidan Kehoe <kehoea@parhasard.net> parents: 5305 diff changeset	137 (defun notevery (cl-predicate cl-seq &rest cl-rest)
f6471e4ae703 Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery. Aidan Kehoe <kehoea@parhasard.net> parents: 5305 diff changeset	138 "Return true if PREDICATE is false of some element of SEQUENCE.
f6471e4ae703 Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery. Aidan Kehoe <kehoea@parhasard.net> parents: 5305 diff changeset	139
f6471e4ae703 Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery. Aidan Kehoe <kehoea@parhasard.net> parents: 5305 diff changeset	140 With optional SEQUENCES, call PREDICATE each time with as many arguments as
f6471e4ae703 Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery. Aidan Kehoe <kehoea@parhasard.net> parents: 5305 diff changeset	141 there are SEQUENCES (plus one for the element from SEQUENCE).
f6471e4ae703 Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery. Aidan Kehoe <kehoea@parhasard.net> parents: 5305 diff changeset	142
f6471e4ae703 Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery. Aidan Kehoe <kehoea@parhasard.net> parents: 5305 diff changeset	143 arguments: (PREDICATE SEQUENCES &rest SEQUENCES)"
f6471e4ae703 Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery. Aidan Kehoe <kehoea@parhasard.net> parents: 5305 diff changeset	144 (not (apply 'every cl-predicate cl-seq cl-rest)))
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 ;;; Support for `loop'.
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	147 (defalias 'cl-map-keymap 'map-keymap)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	148
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	149 (defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	150 (or cl-base
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	151 (setq cl-base (copy-sequence [0])))
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	152 (map-keymap
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	153 (function
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	154 (lambda (cl-key cl-bind)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	155 (aset cl-base (1- (length cl-base)) cl-key)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	156 (if (keymapp cl-bind)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	157 (cl-map-keymap-recursively
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	158 cl-func-rec cl-bind
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	159 (vconcat cl-base (list 0)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	160 (funcall cl-func-rec cl-base cl-bind))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	161 cl-map))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	162
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	163 (defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	164 (or cl-what (setq cl-what (current-buffer)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	165 (if (bufferp cl-what)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	166 (let (cl-mark cl-mark2 (cl-next t) cl-next2)
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	167 (with-current-buffer cl-what
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	168 (setq cl-mark (copy-marker (or cl-start (point-min))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	169 (setq cl-mark2 (and cl-end (copy-marker cl-end))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	170 (while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2)))
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	171 (setq cl-next (if cl-prop (next-single-property-change
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	172 cl-mark cl-prop cl-what)
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	173 (next-property-change cl-mark cl-what))
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	174 cl-next2 (or cl-next (with-current-buffer cl-what
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	175 (point-max))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	176 (funcall cl-func (prog1 (marker-position cl-mark)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	177 (set-marker cl-mark cl-next2))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	178 (if cl-mark2 (min cl-next2 cl-mark2) cl-next2)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	179 (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	180 (or cl-start (setq cl-start 0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	181 (or cl-end (setq cl-end (length cl-what)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	182 (while (< cl-start cl-end)
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	183 (let ((cl-next (or (if cl-prop (next-single-property-change
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	184 cl-start cl-prop cl-what)
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	185 (next-property-change cl-start cl-what))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	186 cl-end)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	187 (funcall cl-func cl-start (min cl-next cl-end))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	188 (setq cl-start cl-next)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	189
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	190 (defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	191 (or cl-buffer (setq cl-buffer (current-buffer)))
502 7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	192 (with-fboundp '(overlay-start overlay-end overlays-at next-overlay-change)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	193 (if-fboundp 'overlay-lists
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	194
502 7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	195 ;; This is the preferred algorithm, though overlay-lists is
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	196 ;; undocumented.
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	197 (let (cl-ovl)
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	198 (with-current-buffer cl-buffer
502 7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	199 (setq cl-ovl (overlay-lists))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	200 (if cl-start (setq cl-start (copy-marker cl-start)))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	201 (if cl-end (setq cl-end (copy-marker cl-end))))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	202 (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl)))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	203 (while (and cl-ovl
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	204 (or (not (overlay-start (car cl-ovl)))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	205 (and cl-end (>= (overlay-start (car cl-ovl)) cl-end))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	206 (and cl-start (<= (overlay-end (car cl-ovl))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	207 cl-start))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	208 (not (funcall cl-func (car cl-ovl) cl-arg))))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	209 (setq cl-ovl (cdr cl-ovl)))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	210 (if cl-start (set-marker cl-start nil))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	211 (if cl-end (set-marker cl-end nil)))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	212
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	213 ;; This alternate algorithm fails to find zero-length overlays.
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	214 (let ((cl-mark (with-current-buffer cl-buffer
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	215 (copy-marker (or cl-start (point-min)))))
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	216 (cl-mark2 (and cl-end (with-current-buffer cl-buffer
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	217 (copy-marker cl-end))))
502 7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	218 cl-pos cl-ovl)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	219 (while (save-excursion
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	220 (and (setq cl-pos (marker-position cl-mark))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	221 (< cl-pos (or cl-mark2 (point-max)))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	222 (progn
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	223 (set-buffer cl-buffer)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	224 (setq cl-ovl (overlays-at cl-pos))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	225 (set-marker cl-mark (next-overlay-change cl-pos)))))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	226 (while (and cl-ovl
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	227 (or (/= (overlay-start (car cl-ovl)) cl-pos)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	228 (not (and (funcall cl-func (car cl-ovl) cl-arg)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	229 (set-marker cl-mark nil)))))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	230 (setq cl-ovl (cdr cl-ovl))))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	231 (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil))))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	232
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	233 ;;; Support for `setf'.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	234 (defun cl-set-frame-visible-p (frame val)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	235 (cond ((null val) (make-frame-invisible frame))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	236 ((eq val 'icon) (iconify-frame frame))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	237 (t (make-frame-visible frame)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	238 val)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	239
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	240 ;;; Support for `progv'.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	241 (defvar cl-progv-save)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	242 (defun cl-progv-before (syms values)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	243 (while syms
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	244 (push (if (boundp (car syms))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	245 (cons (car syms) (symbol-value (car syms)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	246 (car syms)) cl-progv-save)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	247 (if values
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	248 (set (pop syms) (pop values))
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	249 (makunbound (pop syms)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	250
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	251 (defun cl-progv-after ()
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	252 (while cl-progv-save
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	253 (if (consp (car cl-progv-save))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	254 (set (car (car cl-progv-save)) (cdr (car cl-progv-save)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	255 (makunbound (car cl-progv-save)))
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	256 (pop cl-progv-save)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	257
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	258 ;;; Numbers.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	259
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	260 (defun gcd (&rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	261 "Return the greatest common divisor of the arguments."
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	262 (let ((a (abs (or (pop args) 0))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	263 (while args
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	264 (let ((b (abs (pop args))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	265 (while (> b 0) (setq b (% a (setq a b))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	266 a))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	267
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	268 (defun lcm (&rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	269 "Return the least common multiple of the arguments."
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	270 (if (memq 0 args)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	271 0
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	272 (let ((a (abs (or (pop args) 1))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	273 (while args
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	274 (let ((b (abs (pop args))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	275 (setq a (* (/ a (gcd a b)) b))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	276 a)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	277
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	278 (defun isqrt (a)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	279 "Return the integer square root of the argument."
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	280 (if (and (integerp a) (> a 0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	281 ;; XEmacs change
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	282 (let ((g (cond ((>= a 1000000) 10000) ((>= a 10000) 1000)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	283 ((>= a 100) 100) (t 10)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	284 g2)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	285 (while (< (setq g2 (/ (+ g (/ a g)) 2)) g)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	286 (setq g g2))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	287 g)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	288 (if (eq a 0) 0 (signal 'arith-error nil))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	289
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	290 ;; We can't use macrolet in this file; whence the literal macro
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	291 ;; definition-and-call:
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	292 ((macro . (lambda (&rest symbols)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	293 "Make some old CL package truncate and round functions available.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	294
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	295 These functions are now implemented in C; their Lisp implementations in this
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	296 XEmacs are trivial, so we provide them and mark them obsolete."
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	297 (let (symbol result)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	298 (while symbols
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	299 (setq symbol (car symbols)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	300 symbols (cdr symbols))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	301 (push `(make-obsolete ',(intern (format "%s*" symbol))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	302 ',symbol "21.5.29")
4800 b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	303 result)
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	304 (push
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	305 `(defun ,(intern (format "%s*" symbol)) (number &optional divisor)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	306 ,(format "See `%s'. This returns a list, not multiple values."
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	307 symbol)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	308 (multiple-value-list (,symbol number divisor)))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	309 result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	310 (cons 'progn result))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	311 ceiling floor round truncate)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	312
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	313 (defun mod* (x y)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	314 "The remainder of X divided by Y, with the same sign as Y."
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	315 (nth-value 1 (floor x y)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	316
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	317 (defun rem* (x y)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	318 "The remainder of X divided by Y, with the same sign as X."
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	319 (nth-value 1 (truncate x y)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	320
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	321 (defun signum (a)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	322 "Return 1 if A is positive, -1 if negative, 0 if zero."
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	323 (cond ((> a 0) 1) ((< a 0) -1) (t 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	324
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	325 ;; Random numbers.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	326
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	327 (defvar random-state)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	328 (defun random* (lim &optional state)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	329 "Return a random nonnegative number less than LIM, an integer or float.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	330 Optional second arg STATE is a random-state object."
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	331 (or state (setq state random-state))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	332 ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	333 (let ((vec (aref state 3)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	334 (if (integerp vec)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	335 (let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	336 (aset state 3 (setq vec (make-vector 55 nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	337 (aset vec 0 j)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	338 (while (> (setq i (% (+ i 21) 55)) 0)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	339 (aset vec i (setq j (prog1 k (setq k (- j k))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	340 (while (< (setq i (1+ i)) 200) (random* 2 state))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	341 (let* ((i (aset state 1 (% (1+ (aref state 1)) 55)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	342 (j (aset state 2 (% (1+ (aref state 2)) 55)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	343 (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	344 (if (integerp lim)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	345 (if (<= lim 512) (% n lim)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	346 (if (> lim 8388607) (setq n (+ (lsh n 9) (random* 512 state))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	347 (let ((mask 1023))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	348 (while (< mask (1- lim)) (setq mask (1+ (+ mask mask))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	349 (if (< (setq n (logand n mask)) lim) n (random* lim state))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	350 (* (/ n '8388608e0) lim)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	351
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	352 (defun make-random-state (&optional state)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	353 "Return a copy of random-state STATE, or of `random-state' if omitted.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	354 If STATE is t, return a new state object seeded from the time of day."
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	355 (cond ((null state) (make-random-state random-state))
5632 bd80d9103fc8 Integrate CL code better into core, remove obsolete compatibility code. Aidan Kehoe <kehoea@parhasard.net> parents: 5583 diff changeset	356 ((vectorp state) (copy-tree state t))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	357 ((integerp state) (vector 'cl-random-state-tag -1 30 state))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	358 (t (make-random-state (cl-random-time)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	359
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	360 (defun random-state-p (object)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	361 "Return t if OBJECT is a random-state object."
5632 bd80d9103fc8 Integrate CL code better into core, remove obsolete compatibility code. Aidan Kehoe <kehoea@parhasard.net> parents: 5583 diff changeset	362 (and (vectorp object) (eql (length object) 4)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	363 (eq (aref object 0) 'cl-random-state-tag)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	364
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	365 ;;; Sequence functions.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	366
5219 2d0937dc83cf Tidying of CL files; make docstrings read better, remove commented-out code Aidan Kehoe <kehoea@parhasard.net> parents: 5162 diff changeset	367 ;; XEmacs; #'subseq is in C.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	368
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	369 (defun concatenate (type &rest seqs)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	370 "Concatenate, into a sequence of type TYPE, the argument SEQUENCES."
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	371 ;; XEmacs change: use case instead of cond for clarity
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	372 (case type
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	373 (vector (apply 'vconcat seqs))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	374 (string (apply 'concat seqs))
5339 ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5312 diff changeset	375 (list (reduce 'append seqs :from-end t :initial-value nil))
5242 f3eca926258e Bit vectors are also sequences; enforce this in some CL functions. Aidan Kehoe <kehoea@parhasard.net> parents: 5226 diff changeset	376 (bit-vector (apply 'bvconcat seqs))
5339 ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5312 diff changeset	377 (t (coerce (reduce 'append seqs :from-end t :initial-value nil) type))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	378
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	379 ;;; List functions.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	380
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	381 (defun revappend (x y)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	382 "Equivalent to (append (reverse X) Y)."
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	383 (nconc (reverse x) y))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	384
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	385 (defun nreconc (x y)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	386 "Equivalent to (nconc (nreverse X) Y)."
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	387 (nconc (nreverse x) y))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	388
5285 99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5284 diff changeset	389 ;; XEmacs; check LIST for type and circularity.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	390 (defun tailp (sublist list)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	391 "Return true if SUBLIST is a tail of LIST."
5285 99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5284 diff changeset	392 (check-argument-type #'listp list)
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5284 diff changeset	393 (let ((before list) (evenp t))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5284 diff changeset	394 (while (and (consp list) (not (eq sublist list)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5284 diff changeset	395 (setq list (cdr list)
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5284 diff changeset	396 evenp (not evenp))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5284 diff changeset	397 (if evenp (setq before (cdr before)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5284 diff changeset	398 (if (eq before list) (error 'circular-list list)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5284 diff changeset	399 (eql sublist list)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	400
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	401 (defalias 'cl-copy-tree 'copy-tree)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	402
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	403 ;;; Property lists.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	404
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	405 ;; XEmacs: our `get' groks DEFAULT.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	406 (defalias 'get* 'get)
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	407 (defalias 'getf 'plist-get)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	408
5285 99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5284 diff changeset	409 ;; XEmacs; these are built-in.
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5284 diff changeset	410 (defalias 'cl-set-getf 'plist-put)
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5284 diff changeset	411 (defalias 'cl-do-remf 'plist-remprop)
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	412 (defalias 'cl-remprop 'remprop)
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	413
4800 b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	414 (defun get-properties (plist indicator-list)
b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	415 "Find a property from INDICATOR-LIST in PLIST.
b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	416 Return 3 values:
b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	417 - the first property found,
b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	418 - its value,
b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	419 - the tail of PLIST beginning with the found entry."
b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	420 (do ((plst plist (cddr plst)))
b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	421 ((null plst) (values nil nil nil))
b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	422 (cond ((atom (cdr plst))
b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	423 (error "Malformed property list: %S." plist))
b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	424 ((memq (car plst) indicator-list)
b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	425 (return (values (car plst) (cadr plst) plst))))))
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	426
5075 868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	427 ;; See also the compiler macro in cl-macs.el.
5056 6aba0daedb7c Add #'constantly, as specified by ANSI Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4997 diff changeset	428 (defun constantly (value &rest more-values)
6aba0daedb7c Add #'constantly, as specified by ANSI Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4997 diff changeset	429 "Construct a function always returning VALUE, and possibly MORE-VALUES.
6aba0daedb7c Add #'constantly, as specified by ANSI Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4997 diff changeset	430
6aba0daedb7c Add #'constantly, as specified by ANSI Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4997 diff changeset	431 The constructed function accepts any number of arguments, and ignores them.
6aba0daedb7c Add #'constantly, as specified by ANSI Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4997 diff changeset	432
6aba0daedb7c Add #'constantly, as specified by ANSI Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4997 diff changeset	433 Members of MORE-VALUES, if provided, will be passed as multiple values; see
6aba0daedb7c Add #'constantly, as specified by ANSI Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4997 diff changeset	434 `multiple-value-bind' and `multiple-value-setq'."
5075 868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	435 (symbol-macrolet
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	436 ((arglist '(&rest ignore)))
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	437 (if (or more-values (eval-when-compile (not (cl-compiling-file))))
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	438 `(lambda ,arglist (values-list ',(cons value more-values)))
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	439 (make-byte-code
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	440 arglist
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	441 (eval-when-compile
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	442 (let ((compiled (byte-compile-sexp #'(lambda (&rest ignore)
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	443 (declare (ignore ignore))
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	444 'placeholder))))
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	445 (assert (and
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	446 (equal [placeholder]
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	447 (compiled-function-constants compiled))
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	448 (= 1 (compiled-function-stack-depth compiled)))
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	449 t
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	450 "Our assumptions about compiled code appear not to hold.")
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	451 (compiled-function-instructions compiled)))
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	452 (vector value) 1))))
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	453
5632 bd80d9103fc8 Integrate CL code better into core, remove obsolete compatibility code. Aidan Kehoe <kehoea@parhasard.net> parents: 5583 diff changeset	454 ;;; Hash tables. XEmacs; remove the compatibility stuff, which was all that
bd80d9103fc8 Integrate CL code better into core, remove obsolete compatibility code. Aidan Kehoe <kehoea@parhasard.net> parents: 5583 diff changeset	455 ;;; remained here, given the hash table implementation is in C.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	456
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	457 ;;; Some debugging aids.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	458
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	459 (defun cl-prettyprint (form)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	460 "Insert a pretty-printed rendition of a Lisp FORM in current buffer."
5162 41262f87eb39 Handle (function ...) specially, cl-prettyprint. Aidan Kehoe <kehoea@parhasard.net> parents: 5075 diff changeset	461 (let ((pt (point)) last just)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	462 (insert "\n" (prin1-to-string form) "\n")
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	463 (setq last (point))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	464 (goto-char (1+ pt))
5162 41262f87eb39 Handle (function ...) specially, cl-prettyprint. Aidan Kehoe <kehoea@parhasard.net> parents: 5075 diff changeset	465 (while (re-search-forward "(\$?:\\(?:function\\\|quote\$ \\)" last t)
41262f87eb39 Handle (function ...) specially, cl-prettyprint. Aidan Kehoe <kehoea@parhasard.net> parents: 5075 diff changeset	466 (delete-region (match-beginning 0) (match-end 0))
41262f87eb39 Handle (function ...) specially, cl-prettyprint. Aidan Kehoe <kehoea@parhasard.net> parents: 5075 diff changeset	467 (if (= (length "(function ") (- (match-end 0) (match-beginning 0)))
41262f87eb39 Handle (function ...) specially, cl-prettyprint. Aidan Kehoe <kehoea@parhasard.net> parents: 5075 diff changeset	468 (insert "#'")
41262f87eb39 Handle (function ...) specially, cl-prettyprint. Aidan Kehoe <kehoea@parhasard.net> parents: 5075 diff changeset	469 (insert "'"))
41262f87eb39 Handle (function ...) specially, cl-prettyprint. Aidan Kehoe <kehoea@parhasard.net> parents: 5075 diff changeset	470 (setq just (point))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	471 (forward-sexp)
5162 41262f87eb39 Handle (function ...) specially, cl-prettyprint. Aidan Kehoe <kehoea@parhasard.net> parents: 5075 diff changeset	472 (delete-char 1)
41262f87eb39 Handle (function ...) specially, cl-prettyprint. Aidan Kehoe <kehoea@parhasard.net> parents: 5075 diff changeset	473 (goto-char just))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	474 (goto-char (1+ pt))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	475 (cl-do-prettyprint)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	476
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	477 (defun cl-do-prettyprint ()
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	478 (skip-chars-forward " ")
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	479 (if (looking-at "(")
4800 b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	480 (let ((skip (or (looking-at "((")
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	481 ;; XEmacs: be selective about trailing stuff after prog
1729 175ee2cb4d3a [xemacs-hg @ 2003-09-30 22:09:31 by youngs] youngs parents: 801 diff changeset	482 (looking-at "(prog[nv12\$ress-feedback\\\|n-with-message\$]")
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	483 (looking-at "(unwind-protect ")
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	484 (looking-at "(function (")
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	485 (looking-at "(cl-block-wrapper ")))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	486 (two (or (looking-at "(defun ") (looking-at "(defmacro ")))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	487 (let (or (looking-at "(let\\*? ") (looking-at "(while ")))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	488 (set (looking-at "(p?set[qf] ")))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	489 (if (or skip let
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	490 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	491 (forward-sexp)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	492 (and (>= (current-column) 78) (progn (backward-sexp) t))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	493 (let ((nl t))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	494 (forward-char 1)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	495 (cl-do-prettyprint)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	496 (or skip (looking-at ")") (cl-do-prettyprint))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	497 (or (not two) (looking-at ")") (cl-do-prettyprint))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	498 (while (not (looking-at ")"))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	499 (if set (setq nl (not nl)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	500 (if nl (insert "\n"))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	501 (lisp-indent-line)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	502 (cl-do-prettyprint))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	503 (forward-char 1))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	504 (forward-sexp)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	505
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	506 (defvar cl-macroexpand-cmacs nil)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	507 (defvar cl-closure-vars nil)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	508
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	509 (defun cl-macroexpand-all (form &optional env)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	510 "Expand all macro calls through a Lisp FORM.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	511 This also does some trivial optimizations to make the form prettier."
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	512 (while (or (not (eq form (setq form (macroexpand form env))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	513 (and cl-macroexpand-cmacs
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	514 (not (eq form (setq form (compiler-macroexpand form)))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	515 (cond ((not (consp form)) form)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	516 ((memq (car form) '(let let*))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	517 (if (null (nth 1 form))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	518 (cl-macroexpand-all (cons 'progn (cddr form)) env)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	519 (let ((letf nil) (res nil) (lets (cadr form)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	520 (while lets
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	521 (push (if (consp (car lets))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	522 (let ((exp (cl-macroexpand-all (caar lets) env)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	523 (or (symbolp exp) (setq letf t))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	524 (cons exp (cl-macroexpand-body (cdar lets) env)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	525 (let ((exp (cl-macroexpand-all (car lets) env)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	526 (if (symbolp exp) exp
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	527 (setq letf t) (list exp nil)))) res)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	528 (setq lets (cdr lets)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	529 (list* (if letf (if (eq (car form) 'let) 'letf 'letf*) (car form))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	530 (nreverse res) (cl-macroexpand-body (cddr form) env)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	531 ((eq (car form) 'cond)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	532 (cons (car form)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	533 (mapcar (function (lambda (x) (cl-macroexpand-body x env)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	534 (cdr form))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	535 ((eq (car form) 'condition-case)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	536 (list* (car form) (nth 1 form) (cl-macroexpand-all (nth 2 form) env)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	537 (mapcar (function
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	538 (lambda (x)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	539 (cons (car x) (cl-macroexpand-body (cdr x) env))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	540 (cdddr form))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	541 ((memq (car form) '(quote function))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	542 (if (eq (car-safe (nth 1 form)) 'lambda)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	543 (let ((body (cl-macroexpand-body (cddadr form) env)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	544 (if (and cl-closure-vars (eq (car form) 'function)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	545 (cl-expr-contains-any body cl-closure-vars))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	546 (let* ((new (mapcar 'gensym cl-closure-vars))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	547 (sub (pairlis cl-closure-vars new)) (decls nil))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	548 (while (or (stringp (car body))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	549 (eq (car-safe (car body)) 'interactive))
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	550 (push (list 'quote (pop body)) decls))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	551 (put (car (last cl-closure-vars)) 'used t)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	552 (append
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	553 (list 'list '(quote lambda) '(quote (&rest --cl-rest--)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	554 (sublis sub (nreverse decls))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	555 (list
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	556 (list* 'list '(quote apply)
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	557 ;; XEmacs: put a quote before the function
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	558 (list 'list '(quote quote)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	559 (list 'function
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	560 (list* 'lambda
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	561 (append new (cadadr form))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	562 (sublis sub body))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	563 (nconc (mapcar (function
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	564 (lambda (x)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	565 (list 'list '(quote quote) x)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	566 cl-closure-vars)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	567 '((quote --cl-rest--)))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	568 (list (car form) (list* 'lambda (cadadr form) body))))
5562 855b667dea13 Drop cl-macro-environment in favour of byte-compile-macro-environment. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	569 ;; This is a bit of a hack; special-case symbols with bindings as
855b667dea13 Drop cl-macro-environment in favour of byte-compile-macro-environment. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	570 ;; labels.
855b667dea13 Drop cl-macro-environment in favour of byte-compile-macro-environment. Aidan Kehoe <kehoea@parhasard.net> parents: 5476 diff changeset	571 (let ((found (cdr (assq (cadr form) env))))
5656 e9c3fe82127d Co-operate with the byte-optimizer in the bytecomp.el labels implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 5632 diff changeset	572 (cond
e9c3fe82127d Co-operate with the byte-optimizer in the bytecomp.el labels implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 5632 diff changeset	573 ((and (consp found) (eq (nth 1 (nth 1 found)) 'cl-labels-args))
e9c3fe82127d Co-operate with the byte-optimizer in the bytecomp.el labels implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 5632 diff changeset	574 ;; This is the implementation of labels in cl-macs.el.
e9c3fe82127d Co-operate with the byte-optimizer in the bytecomp.el labels implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 5632 diff changeset	575 (cl-macroexpand-all (nth 1 (nth 2 (nth 2 found))) env))
e9c3fe82127d Co-operate with the byte-optimizer in the bytecomp.el labels implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 5632 diff changeset	576 ((and (consp found) (eq (nth 1 (nth 1 found))
e9c3fe82127d Co-operate with the byte-optimizer in the bytecomp.el labels implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 5632 diff changeset	577 'byte-compile-labels-args))
e9c3fe82127d Co-operate with the byte-optimizer in the bytecomp.el labels implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 5632 diff changeset	578 ;; We're using the implementation of labels in
e9c3fe82127d Co-operate with the byte-optimizer in the bytecomp.el labels implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 5632 diff changeset	579 ;; bytecomp.el. Quote its data-placeholder with FUNCTION so
e9c3fe82127d Co-operate with the byte-optimizer in the bytecomp.el labels implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 5632 diff changeset	580 ;; that code can tell uses as data apart from the uses with
e9c3fe82127d Co-operate with the byte-optimizer in the bytecomp.el labels implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 5632 diff changeset	581 ;; funcall.
e9c3fe82127d Co-operate with the byte-optimizer in the bytecomp.el labels implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 5632 diff changeset	582 (unless (eq 'function (car form))
e9c3fe82127d Co-operate with the byte-optimizer in the bytecomp.el labels implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 5632 diff changeset	583 (byte-compile-warn
e9c3fe82127d Co-operate with the byte-optimizer in the bytecomp.el labels implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 5632 diff changeset	584 "deprecated: '%s, use #'%s instead to quote it as a function"
e9c3fe82127d Co-operate with the byte-optimizer in the bytecomp.el labels implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 5632 diff changeset	585 (cadr form) (cadr form)))
e9c3fe82127d Co-operate with the byte-optimizer in the bytecomp.el labels implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 5632 diff changeset	586 (setq found (get (nth 1 (nth 1 (nth 3 found)))
e9c3fe82127d Co-operate with the byte-optimizer in the bytecomp.el labels implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 5632 diff changeset	587 'byte-compile-data-placeholder))
e9c3fe82127d Co-operate with the byte-optimizer in the bytecomp.el labels implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 5632 diff changeset	588 (put found 'byte-compile-label-calls
e9c3fe82127d Co-operate with the byte-optimizer in the bytecomp.el labels implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 5632 diff changeset	589 (1+ (get found 'byte-compile-label-calls 0)))
e9c3fe82127d Co-operate with the byte-optimizer in the bytecomp.el labels implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 5632 diff changeset	590 (list 'function found))
e9c3fe82127d Co-operate with the byte-optimizer in the bytecomp.el labels implementation. Aidan Kehoe <kehoea@parhasard.net> parents: 5632 diff changeset	591 (t form)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	592 ((memq (car form) '(defun defmacro))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	593 (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	594 ((and (eq (car form) 'progn) (not (cddr form)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	595 (cl-macroexpand-all (nth 1 form) env))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	596 ((eq (car form) 'setq)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	597 (let* ((args (cl-macroexpand-body (cdr form) env)) (p args))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	598 (while (and p (symbolp (car p))) (setq p (cddr p)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	599 (if p (cl-macroexpand-all (cons 'setf args)) (cons 'setq args))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	600 (t (cons (car form) (cl-macroexpand-body (cdr form) env)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	601
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	602 (defun cl-macroexpand-body (body &optional env)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	603 (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	604
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	605 (defun cl-prettyexpand (form &optional full)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	606 (message "Expanding...")
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	607 (let ((cl-macroexpand-cmacs full) (cl-compiling-file full)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	608 (byte-compile-macro-environment nil))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	609 (setq form (cl-macroexpand-all form
5632 bd80d9103fc8 Integrate CL code better into core, remove obsolete compatibility code. Aidan Kehoe <kehoea@parhasard.net> parents: 5583 diff changeset	610 (and (not full)
bd80d9103fc8 Integrate CL code better into core, remove obsolete compatibility code. Aidan Kehoe <kehoea@parhasard.net> parents: 5583 diff changeset	611 '((block) (return-from) (eval-when)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	612 (message "Formatting...")
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	613 (prog1 (cl-prettyprint form)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	614 (message ""))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	615
5284 d27c1ee1943b Make the order of preloaded-file-list more sane. Aidan Kehoe <kehoea@parhasard.net> parents: 5273 diff changeset	616 ;; XEmacs addition; force cl-macs to be available from here on when
d27c1ee1943b Make the order of preloaded-file-list more sane. Aidan Kehoe <kehoea@parhasard.net> parents: 5273 diff changeset	617 ;; compiling files to be dumped. This is more reasonable than forcing other
d27c1ee1943b Make the order of preloaded-file-list more sane. Aidan Kehoe <kehoea@parhasard.net> parents: 5273 diff changeset	618 ;; files to do the same, multiple times.
d27c1ee1943b Make the order of preloaded-file-list more sane. Aidan Kehoe <kehoea@parhasard.net> parents: 5273 diff changeset	619 (eval-when-compile (or (cl-compiling-file) (load "cl-macs")))
d27c1ee1943b Make the order of preloaded-file-list more sane. Aidan Kehoe <kehoea@parhasard.net> parents: 5273 diff changeset	620
5772 cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	621 ;; XEmacs, functions from Common Lisp.
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	622 (defun* write-string (string &optional output-stream &key (start 0) end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	623 "Output STRING to stream OUTPUT-STREAM.
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	624
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	625 OUTPUT-STREAM defaults to the value of `standard-output', which see.
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	626
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	627 Keywords :start and :end, if given, specify indices of a subsequence
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	628 of STRING to output. They default to 0 and nil, meaning write the
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	629 entire string.
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	630
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	631 Returns STRING (not the subsequence of STRING that has been written to
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	632 OUTPUT-STREAM)."
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	633 (check-type string string)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	634 (write-sequence string output-stream :start start :end end))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	635
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	636 (defun* write-line (string &optional output-stream &key (start 0) end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	637 "Output STRING, followed by a newline, to OUTPUT-STREAM.
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	638
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	639 STRING must be a string. OUTPUT-STREAM defaults to the value of
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	640 `standard-output' (which see).
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	641
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	642 Keywords :start and :end, if given, specify indices of a subsequence
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	643 of STRING to output. They default to 0 and nil, meaning write the
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	644 entire string.
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	645
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	646 Returns STRING (note, not the subsequence of STRING that has been written to
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	647 OUTPUT-STREAM)."
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	648 (check-type string string)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	649 (prog1
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	650 (write-sequence string output-stream :start start :end end)
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	651 (terpri output-stream)))
cd4f5f1f1f4c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 5656 diff changeset	652
5387 5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	653 ;; Implementation limits.
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	654
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	655 ;; XEmacs; call cl-float-limits at dump time.
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	656 (labels
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	657 ((cl-finite-do (func a b)
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	658 (condition-case nil
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	659 (let ((res (funcall func a b))) ; check for IEEE infinity
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	660 (and (numberp res) (/= res (/ res 2)) res))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	661 (arith-error nil)))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	662 (cl-float-limits ()
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	663 (unless most-positive-float
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	664 (let ((x 2e0) y z)
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	665 ;; Find maximum exponent (first two loops are optimizations)
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	666 (while (cl-finite-do '* x x) (setq x (* x x)))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	667 (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	668 (while (cl-finite-do '+ x x) (setq x (+ x x)))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	669 (setq z x y (/ x 2))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	670 ;; Now fill in 1's in the mantissa.
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	671 (while (and (cl-finite-do '+ x y) (/= (+ x y) x))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	672 (setq x (+ x y) y (/ y 2)))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	673 (setq most-positive-float x
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	674 most-negative-float (- x))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	675 ;; Divide down until mantissa starts rounding.
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	676 (setq x (/ x z) y (/ 16 z) x (* x y))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	677 (while (condition-case nil (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	678 (arith-error nil))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	679 (setq x (/ x 2) y (/ y 2)))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	680 (setq least-positive-normalized-float y
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	681 least-negative-normalized-float (- y))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	682 ;; Divide down until value underflows to zero.
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	683 (setq x (/ 1 z) y x)
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	684 (while (condition-case nil (> (/ x 2) 0) (arith-error nil))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	685 (setq x (/ x 2)))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	686 (setq least-positive-float x
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	687 least-negative-float (- x))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	688 (setq x 1e0)
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	689 (while (/= (+ 1e0 x) 1e0) (setq x (/ x 2)))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	690 (setq float-epsilon (* x 2))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	691 (setq x 1e0)
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	692 (while (/= (- 1e0 x) 1e0) (setq x (/ x 2)))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	693 (setq float-negative-epsilon (* x 2))))))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	694 (cl-float-limits))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	695
5400 aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	696
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	697 ;;; Character functions.
5461 568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	698 (macrolet
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	699 ((define-char-comparisons (&rest alist)
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	700 "Provide Common Lisp's character-specific comparison predicates.
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	701
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	702 These throw errors if any arguments are non-characters, conflicting with
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	703 typical emacs behavior. This is not the case if
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	704 `byte-compile-delete-errors' is non-nil; see the documentation of that
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	705 variable.
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	706
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	707 This doesn't include the case-insensitive comparisons, and it probably
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	708 should."
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	709 (let* ((functions (mapcar 'car alist))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	710 (map (mapcar #'(lambda (symbol)
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	711 `(,symbol .
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	712 ,(intern (substring (symbol-name symbol)
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	713 (length "char")))))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	714 functions)))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	715 `(progn
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	716 (mapc
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	717 (function*
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	718 (lambda ((function . cl-unsafe-comparison))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	719 (put function 'cl-unsafe-comparison cl-unsafe-comparison)
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	720 (put function 'cl-compiler-macro
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	721 #'(lambda (form &rest arguments)
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	722 (if byte-compile-delete-errors
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	723 (cons (get (car form) 'cl-unsafe-comparison)
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	724 (cdr form))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	725 form)))))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	726 ',map)
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	727 ,@(mapcar
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	728 (function*
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	729 (lambda ((function . documentation))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	730 `(defun ,function (character &rest more-characters)
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	731 ,documentation
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	732 (check-type character character)
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	733 (check-type more-characters
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	734 (satisfies (lambda (list)
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	735 (every 'characterp list))))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	736 (apply ',(cdr (assq function map))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	737 character more-characters))))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	738 alist)))))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	739 (define-char-comparisons
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	740 (char= . "Return t if all character arguments are the same object.")
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	741 (char/= . "Return t if no two character arguments are the same object.")
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	742 (char< . "Return t if the character arguments monotonically increase.")
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	743 (char> . "Return t if the character arguments monotonically decrease.")
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	744 (char<= . "Return t if the character arguments are monotonically \
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	745 nondecreasing.")
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	746 (char>= . "Return t if the character arguments are monotonically \
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	747 nonincreasing.")))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. Aidan Kehoe <kehoea@parhasard.net> parents: 5400 diff changeset	748
5400 aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	749 (defun* digit-char-p (character &optional (radix 10))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	750 "Return non-nil if CHARACTER represents a digit in base RADIX.
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	751
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	752 RADIX defaults to ten. The actual non-nil value returned is the integer
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	753 value of the character in base RADIX."
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	754 (check-type character character)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	755 (check-type radix integer)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	756 (if (<= radix 10)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	757 (and (<= ?0 character (+ ?0 radix -1)) (- character ?0))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	758 (or (and (<= ?0 character ?9) (- character ?0))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	759 (and (<= ?a character (+ ?a (setq radix (- radix 11))))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	760 (+ character (- 10 ?a)))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	761 (and (<= ?A character (+ ?A radix))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	762 (+ character (- 10 ?A))))))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	763
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	764 (defun* digit-char (weight &optional (radix 10))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	765 "Return a character representing the integer WEIGHT in base RADIX.
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	766
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	767 RADIX defaults to ten. If no such character exists, return nil."
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	768 (check-type weight integer)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	769 (check-type radix integer)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	770 (and (natnump weight) (< weight radix)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	771 (if (< weight 10)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	772 (int-char (+ ?0 weight))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	773 (int-char (+ ?A (- weight 10))))))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	774
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	775 (defun alpha-char-p (character)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	776 "Return t if CHARACTER is alphabetic, in some alphabet.
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	777
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	778 Han characters are regarded as alphabetic."
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	779 (check-type character character)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	780 (and (eql ?w (char-syntax character (standard-syntax-table)))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	781 (not (<= ?0 character ?9))))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	782
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	783 (defun graphic-char-p (character)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	784 "Return t if CHARACTER is not a control character.
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	785
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	786 Control characters are those in the range ?\\x00 to ?\\x15 and ?\\x7f to
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	787 ?\\x9f, inclusive."
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	788 (check-type character character)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	789 (not (or (<= ?\x00 character ?\x1f) (<= ?\x7f character ?\x9f))))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	790
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	791 (defun standard-char-p (character)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	792 "Return t if CHARACTER is one of Common Lisp's standard characters.
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	793
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	794 These are the non-control ASCII characters, plus the newline character."
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	795 (check-type character character)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	796 (or (<= ?\x20 character ?\x7e) (eql character ?\n)))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	797
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	798 (symbol-macrolet
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	799 ((names '((?\x08 . "Backspace") (?\x09 . "Tab") (?\x0a . "Newline")
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	800 (?\x0C . "Page") (?\x0d . "Return") (?\x20 . "Space")
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	801 (?\x7f . "Rubout"))))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	802
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	803 (defun char-name (character)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	804 "Return a string naming CHARACTER.
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	805
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	806 For the limited number of characters where the character name has been
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	807 specified by Common Lisp, this always returns the appropriate string
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	808 name. Otherwise, `char-name' requires that the Unicode database be
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	809 available; see `describe-char-unicode-data'."
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	810 (check-type character character)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	811 (or (cdr (assq character names))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	812 (let ((unicode-data
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	813 (assoc "Name" (describe-char-unicode-data character))))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	814 (and unicode-data
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	815 (if (string-match "^<[^>]+>$" (cadr unicode-data))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	816 (format "U%04X" (char-to-unicode character))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	817 (replace-in-string (cadr unicode-data) " " "_" t))))))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	818
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	819 (defun name-char (name)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	820 "Return a character with name NAME, a string."
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	821 (or (car (rassoc* name names :test #'equalp))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	822 (if (string-match "^[uU][0-9A-Fa-f]+$" name)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	823 (unicode-to-char (string-to-number (subseq name 1) 16))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	824 (with-current-buffer (get-buffer-create " Unicode Data")
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	825 (require 'descr-text)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	826 (when (zerop (buffer-size))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	827 ;; Don't use -literally in case of DOS line endings.
5632 bd80d9103fc8 Integrate CL code better into core, remove obsolete compatibility code. Aidan Kehoe <kehoea@parhasard.net> parents: 5583 diff changeset	828 (insert-file-contents
bd80d9103fc8 Integrate CL code better into core, remove obsolete compatibility code. Aidan Kehoe <kehoea@parhasard.net> parents: 5583 diff changeset	829 (declare-boundp describe-char-unicodedata-file)))
5400 aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	830 (goto-char (point-min))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	831 (setq case-fold-search nil)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	832 (and (re-search-forward (format #r"^$[0-9A-F]\{4,6\}$;%s;"
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	833 (upcase (replace-in-string
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	834 name "_" " " t))) nil t)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	835 (unicode-to-char (string-to-number (match-string 1) 16))))))))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	836
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	837 (defun upper-case-p (character)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	838 "Return t if CHARACTER is majuscule in the standard case table."
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	839 (and (stringp character) (check-type character character))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	840 (with-case-table (standard-case-table)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	841 (not (eq character (downcase character)))))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	842
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	843 (defun lower-case-p (character)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	844 "Return t if CHARACTER is minuscule in the standard case table."
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	845 (and (stringp character) (check-type character character))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	846 (with-case-table (standard-case-table)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	847 (not (eq character (upcase character)))))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	848
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	849 (defun both-case-p (character)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	850 "Return t if CHARACTER has case information in the standard case table."
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	851 (and (stringp character) (check-type character character))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	852 (with-case-table (standard-case-table)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	853 (or (not (eq character (upcase character)))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	854 (not (eq character (downcase character))))))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	855
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	856 (defun char-upcase (character)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	857 "If CHARACTER is lowercase, return its corresponding uppercase character.
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	858 Otherwise, return CHARACTER."
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	859 (and (stringp character) (check-type character character))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	860 (with-case-table (standard-case-table) (upcase character)))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	861
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	862 (defun char-downcase (character)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	863 "If CHARACTER is uppercase, return its corresponding lowercase character.
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	864 Otherwise, return CHARACTER."
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	865 (and (stringp character) (check-type character character))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	866 (with-case-table (standard-case-table) (downcase character)))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	867
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	868 (defun integer-length (integer)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	869 "Return the number of bits need to represent INTEGER in two's complement."
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	870 (ecase (signum integer)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	871 (0 0)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	872 (-1 (1- (length (format "%b" (- integer)))))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	873 (1 (length (format "%b" integer)))))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	874
5583 10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	875 ;; These are here because labels and symbol-macrolet are not available in
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	876 ;; obsolete.el. They are, however, all marked as obsolete in that file.
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	877 (symbol-macrolet ((not-nil '#:not-nil))
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	878 (labels ((car-or-not-nil (object)
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	879 (if (consp object) (car object) not-nil))
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	880 (cdr-or-not-nil (object)
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	881 (if (consp object) (cdr object) not-nil)))
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	882 (defalias 'remassoc
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	883 #'(lambda (key alist)
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	884 (delete* key alist :test #'equal
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	885 :key (if key #'car-safe #'car-or-not-nil))))
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	886 (defalias 'remrassoc
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	887 #'(lambda (key alist)
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	888 (delete* key alist :test #'equal
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	889 :key (if key #'cdr-safe #'cdr-or-not-nil))))
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	890 (defalias 'remrassq
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	891 #'(lambda (key alist)
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	892 (delete* key alist :test #'eq
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	893 :key (if key #'cdr-safe #'cdr-or-not-nil))))
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	894 (defalias 'remassq
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	895 #'(lambda (key alist)
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	896 (delete* key alist :test #'eq
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	897 :key (if key #'car-safe #'car-or-not-nil))))))
10f179710250 Deprecate #'remassoc, #'remassq, #'remrassoc, #'remrassq. Aidan Kehoe <kehoea@parhasard.net> parents: 5574 diff changeset	898
5632 bd80d9103fc8 Integrate CL code better into core, remove obsolete compatibility code. Aidan Kehoe <kehoea@parhasard.net> parents: 5583 diff changeset	899 ;; XEmacs; since cl-extra.el is dumped, cl-extra-load-hook is
bd80d9103fc8 Integrate CL code better into core, remove obsolete compatibility code. Aidan Kehoe <kehoea@parhasard.net> parents: 5583 diff changeset	900 ;; useless. (Dumped files normally shouldn't be using hooks, functionality
bd80d9103fc8 Integrate CL code better into core, remove obsolete compatibility code. Aidan Kehoe <kehoea@parhasard.net> parents: 5583 diff changeset	901 ;; should be implemented explicitly.)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	902
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	903 ;; XEmacs addition
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	904 (provide 'cl-extra)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	905
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	906 ;;; arch-tag: bcd03437-0871-43fb-a8f1-ad0e0b5427ed
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	907 ;;; cl-extra.el ends here

Mercurial > hg > xemacs-beta

annotate lisp/cl-extra.el @ 5940:c608d4b0b75e cygwin64 tip