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

annotate lisp/cl-extra.el @ 5475:248176c74e6b

Merge with trunk.

author	Mats Lidell <matsl@xemacs.org>
date	Sat, 23 Apr 2011 23:47:13 +0200
parents	0af042a0c116 aa78b0b0b289
children	f2881cb841b4

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
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	49 (eval-when-compile
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	50 (require 'obsolete))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	51
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	52 ;;; Type coercion.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	53
5305 09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	54 (defun coerce (object type)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	55 "Coerce OBJECT to type TYPE.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	56 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	57 (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	58 ((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	59 ((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	60 ((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	61 ((and (eq type 'character) (stringp object)
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	62 (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	63 ((and (eq type 'character) (symbolp object))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	64 (coerce (symbol-name object) type))
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	65 ;; XEmacs addition character <-> integer coercions
5305 09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	66 ((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	67 ((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	68 (char-int object))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	69 ((eq type 'float) (float object))
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	70 ;; XEmacs addition: enhanced numeric type coercions
2367 ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben] ben parents: 2153 diff changeset	71 ((and-fboundp 'coerce-number
5257 30bf66dd3ca0 Add fixnum as an accepted destination type, #'coerce Aidan Kehoe <kehoea@parhasard.net> parents: 5242 diff changeset	72 (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	73 (coerce-number object type)))
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	74 ;; 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	75 ((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	76 (eq type 'simple-bit-vector))
5305 09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	77 (if (bit-vector-p object)
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	78 object
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	79 (apply 'bit-vector (append object nil))))
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	80 ;; XEmacs addition: weak-list coercion
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	81 ((eq type 'weak-list)
5305 09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	82 (if (weak-list-p object) object
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	83 (let ((wl (make-weak-list)))
5305 09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	84 (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	85 object
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	86 (append object nil)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	87 wl)))
4995 8431b52e43b1 Move the various map* functions to C; add #'map-into. Aidan Kehoe <kehoea@parhasard.net> parents: 4800 diff changeset	88 ((and
5305 09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	89 (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	90 (loop
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	91 for (ignore elements length) = type
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	92 initially (declare (special ignore))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	93 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	94 (cond
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	95 ((memq elements '(t * nil))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	96 (coerce object 'vector))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	97 ((memq elements '(string-char character))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	98 (coerce object 'string))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	99 ((eq elements 'bit)
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	100 (coerce object 'bit-vector)))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	101 (error
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	102 'wrong-type-argument
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	103 "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	104 type)))))
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	105 ((eq (car-safe type) 'simple-vector)
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	106 (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	107 ((memq (car-safe type)
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	108 '(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	109 (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	110 ((eq (car-safe type) 'bit-vector)
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	111 (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	112 ((typep object type) object)
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	113 (t (error 'invalid-operation
09fed7053634 Handle slightly more complex type specifications, #'coerce, #'typep. Aidan Kehoe <kehoea@parhasard.net> parents: 5285 diff changeset	114 "Can't coerce object to type" object type))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	115
5219 2d0937dc83cf Tidying of CL files; make docstrings read better, remove commented-out code Aidan Kehoe <kehoea@parhasard.net> parents: 5162 diff changeset	116 ;; XEmacs; #'equalp is in C.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	117
4997 8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX. Aidan Kehoe <kehoea@parhasard.net> parents: 4996 diff changeset	118 ;; 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	119 ;; 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	120
5226 7789ae555c45 Add Common Lisp's #'complement to cl-extra.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5219 diff changeset	121 ;; 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	122 ;; 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	123 ;; function.
7789ae555c45 Add Common Lisp's #'complement to cl-extra.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5219 diff changeset	124 (defun complement (function &optional documentation)
7789ae555c45 Add Common Lisp's #'complement to cl-extra.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5219 diff changeset	125 "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	126 `(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	127 (not (apply ',function arguments))))
7789ae555c45 Add Common Lisp's #'complement to cl-extra.el. Aidan Kehoe <kehoea@parhasard.net> parents: 5219 diff changeset	128
5312 f6471e4ae703 Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery. Aidan Kehoe <kehoea@parhasard.net> parents: 5305 diff changeset	129 (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	130 "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	131
f6471e4ae703 Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery. Aidan Kehoe <kehoea@parhasard.net> parents: 5305 diff changeset	132 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	133 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	134
f6471e4ae703 Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery. Aidan Kehoe <kehoea@parhasard.net> parents: 5305 diff changeset	135 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	136 (not (apply 'some cl-predicate cl-seq cl-rest)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	137
5312 f6471e4ae703 Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery. Aidan Kehoe <kehoea@parhasard.net> parents: 5305 diff changeset	138 (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	139 "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	140
f6471e4ae703 Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery. Aidan Kehoe <kehoea@parhasard.net> parents: 5305 diff changeset	141 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	142 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	143
f6471e4ae703 Avoid some dynamic scope stupidity in interpreted code, #'notany, #'notevery. Aidan Kehoe <kehoea@parhasard.net> parents: 5305 diff changeset	144 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	145 (not (apply 'every cl-predicate cl-seq cl-rest)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	146
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	147 ;;; Support for `loop'.
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	148 (defalias 'cl-map-keymap 'map-keymap)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	149
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	150 (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	151 (or cl-base
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	152 (setq cl-base (copy-sequence [0])))
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	153 (map-keymap
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	154 (function
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	155 (lambda (cl-key cl-bind)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	156 (aset cl-base (1- (length cl-base)) cl-key)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	157 (if (keymapp cl-bind)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	158 (cl-map-keymap-recursively
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	159 cl-func-rec cl-bind
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	160 (vconcat cl-base (list 0)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	161 (funcall cl-func-rec cl-base cl-bind))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	162 cl-map))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	163
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	164 (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	165 (or cl-what (setq cl-what (current-buffer)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	166 (if (bufferp cl-what)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	167 (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	168 (with-current-buffer cl-what
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	169 (setq cl-mark (copy-marker (or cl-start (point-min))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	170 (setq cl-mark2 (and cl-end (copy-marker cl-end))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	171 (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	172 (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	173 cl-mark cl-prop cl-what)
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	174 (next-property-change cl-mark cl-what))
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	175 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	176 (point-max))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	177 (funcall cl-func (prog1 (marker-position cl-mark)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	178 (set-marker cl-mark cl-next2))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	179 (if cl-mark2 (min cl-next2 cl-mark2) cl-next2)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	180 (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	181 (or cl-start (setq cl-start 0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	182 (or cl-end (setq cl-end (length cl-what)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	183 (while (< cl-start cl-end)
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	184 (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	185 cl-start cl-prop cl-what)
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	186 (next-property-change cl-start cl-what))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	187 cl-end)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	188 (funcall cl-func cl-start (min cl-next cl-end))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	189 (setq cl-start cl-next)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	190
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	191 (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	192 (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	193 (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	194 (if-fboundp 'overlay-lists
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	195
502 7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	196 ;; 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	197 ;; undocumented.
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	198 (let (cl-ovl)
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	199 (with-current-buffer cl-buffer
502 7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	200 (setq cl-ovl (overlay-lists))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	201 (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	202 (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	203 (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	204 (while (and cl-ovl
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	205 (or (not (overlay-start (car cl-ovl)))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	206 (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	207 (and cl-start (<= (overlay-end (car cl-ovl))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	208 cl-start))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	209 (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	210 (setq cl-ovl (cdr cl-ovl)))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	211 (if cl-start (set-marker cl-start nil))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	212 (if cl-end (set-marker cl-end nil)))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	213
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	214 ;; 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	215 (let ((cl-mark (with-current-buffer cl-buffer
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	216 (copy-marker (or cl-start (point-min)))))
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	217 (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	218 (copy-marker cl-end))))
502 7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	219 cl-pos cl-ovl)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	220 (while (save-excursion
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	221 (and (setq cl-pos (marker-position cl-mark))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	222 (< cl-pos (or cl-mark2 (point-max)))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	223 (progn
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	224 (set-buffer cl-buffer)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	225 (setq cl-ovl (overlays-at cl-pos))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	226 (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	227 (while (and cl-ovl
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	228 (or (/= (overlay-start (car cl-ovl)) cl-pos)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	229 (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	230 (set-marker cl-mark nil)))))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	231 (setq cl-ovl (cdr cl-ovl))))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben] ben parents: 446 diff changeset	232 (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	233
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	234 ;;; Support for `setf'.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	235 (defun cl-set-frame-visible-p (frame val)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	236 (cond ((null val) (make-frame-invisible frame))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	237 ((eq val 'icon) (iconify-frame frame))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	238 (t (make-frame-visible frame)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	239 val)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	240
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	241 ;;; Support for `progv'.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	242 (defvar cl-progv-save)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	243 (defun cl-progv-before (syms values)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	244 (while syms
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	245 (push (if (boundp (car syms))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	246 (cons (car syms) (symbol-value (car syms)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	247 (car syms)) cl-progv-save)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	248 (if values
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	249 (set (pop syms) (pop values))
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	250 (makunbound (pop syms)))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	251
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	252 (defun cl-progv-after ()
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	253 (while cl-progv-save
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	254 (if (consp (car cl-progv-save))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	255 (set (car (car cl-progv-save)) (cdr (car cl-progv-save)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	256 (makunbound (car cl-progv-save)))
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	257 (pop cl-progv-save)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	258
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	259 ;;; Numbers.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	260
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	261 (defun gcd (&rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	262 "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	263 (let ((a (abs (or (pop args) 0))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	264 (while args
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	265 (let ((b (abs (pop args))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	266 (while (> b 0) (setq b (% a (setq a b))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	267 a))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	268
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	269 (defun lcm (&rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	270 "Return the least common multiple of the arguments."
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	271 (if (memq 0 args)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	272 0
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	273 (let ((a (abs (or (pop args) 1))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	274 (while args
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	275 (let ((b (abs (pop args))))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	276 (setq a (* (/ a (gcd a b)) b))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	277 a)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	278
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	279 (defun isqrt (a)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	280 "Return the integer square root of the argument."
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	281 (if (and (integerp a) (> a 0))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	282 ;; XEmacs change
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	283 (let ((g (cond ((>= a 1000000) 10000) ((>= a 10000) 1000)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	284 ((>= a 100) 100) (t 10)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	285 g2)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	286 (while (< (setq g2 (/ (+ g (/ a g)) 2)) g)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	287 (setq g g2))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	288 g)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	289 (if (eq a 0) 0 (signal 'arith-error nil))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	290
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	291 ;; 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	292 ;; definition-and-call:
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	293 ((macro . (lambda (&rest symbols)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	294 "Make some old CL package truncate and round functions available.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	295
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	296 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	297 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	298 (let (symbol result)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	299 (while symbols
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	300 (setq symbol (car symbols)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	301 symbols (cdr symbols))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	302 (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	303 ',symbol "21.5.29")
4800 b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	304 result)
4678 b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	305 (push
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	306 `(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	307 ,(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	308 symbol)
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	309 (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	310 result))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	311 (cons 'progn result))))
b5e1d4f6b66f Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 2367 diff changeset	312 ceiling floor round truncate)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	313
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	314 (defun mod* (x y)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	315 "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	316 (nth-value 1 (floor x y)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	317
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	318 (defun rem* (x y)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	319 "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	320 (nth-value 1 (truncate x y)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	321
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	322 (defun signum (a)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	323 "Return 1 if A is positive, -1 if negative, 0 if zero."
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	324 (cond ((> a 0) 1) ((< a 0) -1) (t 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	325
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	326 ;; Random numbers.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	327
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	328 (defvar random-state)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	329 (defun random* (lim &optional state)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	330 "Return a random nonnegative number less than LIM, an integer or float.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	331 Optional second arg STATE is a random-state object."
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	332 (or state (setq state random-state))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	333 ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	334 (let ((vec (aref state 3)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	335 (if (integerp vec)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	336 (let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	337 (aset state 3 (setq vec (make-vector 55 nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	338 (aset vec 0 j)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	339 (while (> (setq i (% (+ i 21) 55)) 0)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	340 (aset vec i (setq j (prog1 k (setq k (- j k))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	341 (while (< (setq i (1+ i)) 200) (random* 2 state))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	342 (let* ((i (aset state 1 (% (1+ (aref state 1)) 55)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	343 (j (aset state 2 (% (1+ (aref state 2)) 55)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	344 (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	345 (if (integerp lim)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	346 (if (<= lim 512) (% n lim)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	347 (if (> lim 8388607) (setq n (+ (lsh n 9) (random* 512 state))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	348 (let ((mask 1023))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	349 (while (< mask (1- lim)) (setq mask (1+ (+ mask mask))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	350 (if (< (setq n (logand n mask)) lim) n (random* lim state))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	351 (* (/ n '8388608e0) lim)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	352
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	353 (defun make-random-state (&optional state)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	354 "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	355 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	356 (cond ((null state) (make-random-state random-state))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	357 ((vectorp state) (cl-copy-tree state t))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	358 ((integerp state) (vector 'cl-random-state-tag -1 30 state))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	359 (t (make-random-state (cl-random-time)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	360
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	361 (defun random-state-p (object)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	362 "Return t if OBJECT is a random-state object."
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	363 (and (vectorp object) (= (length object) 4)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	364 (eq (aref object 0) 'cl-random-state-tag)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	365
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	366 ;;; Sequence functions.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	367
5219 2d0937dc83cf Tidying of CL files; make docstrings read better, remove commented-out code Aidan Kehoe <kehoea@parhasard.net> parents: 5162 diff changeset	368 ;; XEmacs; #'subseq is in C.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	369
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	370 (defun concatenate (type &rest seqs)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	371 "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	372 ;; XEmacs change: use case instead of cond for clarity
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	373 (case type
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	374 (vector (apply 'vconcat seqs))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	375 (string (apply 'concat seqs))
5339 ba62563ec7c7 Accept more complex TYPEs in #'concatenate, cl-extra.el Aidan Kehoe <kehoea@parhasard.net> parents: 5312 diff changeset	376 (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	377 (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	378 (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	379
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	380 ;;; List functions.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	381
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	382 (defun revappend (x y)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	383 "Equivalent to (append (reverse X) Y)."
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	384 (nconc (reverse x) y))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	385
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	386 (defun nreconc (x y)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	387 "Equivalent to (nconc (nreverse X) Y)."
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	388 (nconc (nreverse x) y))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	389
5285 99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5284 diff changeset	390 ;; XEmacs; check LIST for type and circularity.
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	391 (defun tailp (sublist list)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	392 "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	393 (check-argument-type #'listp list)
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5284 diff changeset	394 (let ((before list) (evenp t))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5284 diff changeset	395 (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	396 (setq list (cdr list)
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5284 diff changeset	397 evenp (not evenp))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5284 diff changeset	398 (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	399 (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	400 (eql sublist list)))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	401
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	402 (defalias 'cl-copy-tree 'copy-tree)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	403
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	404 ;;; Property lists.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	405
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	406 ;; XEmacs: our `get' groks DEFAULT.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	407 (defalias 'get* 'get)
442 abe6d1db359e Import from CVS: tag r21-2-36 cvs parents: 440 diff changeset	408 (defalias 'getf 'plist-get)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	409
5285 99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5284 diff changeset	410 ;; XEmacs; these are built-in.
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff Aidan Kehoe <kehoea@parhasard.net> parents: 5284 diff changeset	411 (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	412 (defalias 'cl-do-remf 'plist-remprop)
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	413 (defalias 'cl-remprop 'remprop)
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	414
4800 b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	415 (defun get-properties (plist indicator-list)
b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	416 "Find a property from INDICATOR-LIST in PLIST.
b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	417 Return 3 values:
b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	418 - the first property found,
b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	419 - its value,
b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	420 - 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	421 (do ((plst plist (cddr plst)))
b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	422 ((null plst) (values nil nil nil))
b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	423 (cond ((atom (cdr plst))
b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	424 (error "Malformed property list: %S." plist))
b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	425 ((memq (car plst) indicator-list)
b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	426 (return (values (car plst) (cadr plst) plst))))))
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	427
5075 868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	428 ;; 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	429 (defun constantly (value &rest more-values)
6aba0daedb7c Add #'constantly, as specified by ANSI Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4997 diff changeset	430 "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	431
6aba0daedb7c Add #'constantly, as specified by ANSI Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4997 diff changeset	432 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	433
6aba0daedb7c Add #'constantly, as specified by ANSI Common Lisp. Aidan Kehoe <kehoea@parhasard.net> parents: 4997 diff changeset	434 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	435 `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	436 (symbol-macrolet
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	437 ((arglist '(&rest ignore)))
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	438 (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	439 `(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	440 (make-byte-code
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	441 arglist
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	442 (eval-when-compile
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	443 (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	444 (declare (ignore ignore))
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	445 'placeholder))))
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	446 (assert (and
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	447 (equal [placeholder]
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	448 (compiled-function-constants compiled))
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	449 (= 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	450 t
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	451 "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	452 (compiled-function-instructions compiled)))
868a9ffcc37b Normally return a compiled function if one argument, #'constantly. Aidan Kehoe <kehoea@parhasard.net> parents: 5056 diff changeset	453 (vector value) 1))))
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	454
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	455 ;;; Hash tables.
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 ;; The `regular' Common Lisp hash-table stuff has been moved into C.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	458 ;; Only backward compatibility stuff remains here.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	459 (defun make-hashtable (size &optional test)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	460 (make-hash-table :test test :size size))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	461 (defun make-weak-hashtable (size &optional test)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	462 (make-hash-table :test test :size size :weakness t))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	463 (defun make-key-weak-hashtable (size &optional test)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	464 (make-hash-table :test test :size size :weakness 'key))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	465 (defun make-value-weak-hashtable (size &optional test)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	466 (make-hash-table :test test :size size :weakness 'value))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	467
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	468 (define-obsolete-function-alias 'hashtablep 'hash-table-p)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	469 (define-obsolete-function-alias 'hashtable-fullness 'hash-table-count)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	470 (define-obsolete-function-alias 'hashtable-test-function 'hash-table-test)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	471 (define-obsolete-function-alias 'hashtable-type 'hash-table-type)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	472 (define-obsolete-function-alias 'hashtable-size 'hash-table-size)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	473 (define-obsolete-function-alias 'copy-hashtable 'copy-hash-table)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	474
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	475 (make-obsolete 'make-hashtable 'make-hash-table)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	476 (make-obsolete 'make-weak-hashtable 'make-hash-table)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	477 (make-obsolete 'make-key-weak-hashtable 'make-hash-table)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	478 (make-obsolete 'make-value-weak-hashtable 'make-hash-table)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	479 (make-obsolete 'hash-table-type 'hash-table-weakness)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	480
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	481 (when (fboundp 'x-keysym-hash-table)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	482 (make-obsolete 'x-keysym-hashtable 'x-keysym-hash-table))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	483
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	484 ;; Compatibility stuff for old kludgy cl.el hash table implementation
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	485 (defvar cl-builtin-gethash (symbol-function 'gethash))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	486 (defvar cl-builtin-remhash (symbol-function 'remhash))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	487 (defvar cl-builtin-clrhash (symbol-function 'clrhash))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	488 (defvar cl-builtin-maphash (symbol-function 'maphash))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	489
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	490 (defalias 'cl-gethash 'gethash)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	491 (defalias 'cl-puthash 'puthash)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	492 (defalias 'cl-remhash 'remhash)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	493 (defalias 'cl-clrhash 'clrhash)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	494 (defalias 'cl-maphash 'maphash)
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	495 ;; These three actually didn't exist in Emacs-20.
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	496 (defalias 'cl-make-hash-table 'make-hash-table)
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	497 (defalias 'cl-hash-table-p 'hash-table-p)
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	498 (defalias 'cl-hash-table-count 'hash-table-count)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	499
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	500 ;;; Some debugging aids.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	501
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	502 (defun cl-prettyprint (form)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	503 "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	504 (let ((pt (point)) last just)
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	505 (insert "\n" (prin1-to-string form) "\n")
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	506 (setq last (point))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	507 (goto-char (1+ pt))
5162 41262f87eb39 Handle (function ...) specially, cl-prettyprint. Aidan Kehoe <kehoea@parhasard.net> parents: 5075 diff changeset	508 (while (re-search-forward "(\$?:\\(?:function\\\|quote\$ \\)" last t)
41262f87eb39 Handle (function ...) specially, cl-prettyprint. Aidan Kehoe <kehoea@parhasard.net> parents: 5075 diff changeset	509 (delete-region (match-beginning 0) (match-end 0))
41262f87eb39 Handle (function ...) specially, cl-prettyprint. Aidan Kehoe <kehoea@parhasard.net> parents: 5075 diff changeset	510 (if (= (length "(function ") (- (match-end 0) (match-beginning 0)))
41262f87eb39 Handle (function ...) specially, cl-prettyprint. Aidan Kehoe <kehoea@parhasard.net> parents: 5075 diff changeset	511 (insert "#'")
41262f87eb39 Handle (function ...) specially, cl-prettyprint. Aidan Kehoe <kehoea@parhasard.net> parents: 5075 diff changeset	512 (insert "'"))
41262f87eb39 Handle (function ...) specially, cl-prettyprint. Aidan Kehoe <kehoea@parhasard.net> parents: 5075 diff changeset	513 (setq just (point))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	514 (forward-sexp)
5162 41262f87eb39 Handle (function ...) specially, cl-prettyprint. Aidan Kehoe <kehoea@parhasard.net> parents: 5075 diff changeset	515 (delete-char 1)
41262f87eb39 Handle (function ...) specially, cl-prettyprint. Aidan Kehoe <kehoea@parhasard.net> parents: 5075 diff changeset	516 (goto-char just))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	517 (goto-char (1+ pt))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	518 (cl-do-prettyprint)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	519
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	520 (defun cl-do-prettyprint ()
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	521 (skip-chars-forward " ")
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	522 (if (looking-at "(")
4800 b828e06dbe38 New (Common Lisp) function get-propertie Didier Verna <didier@xemacs.org> parents: 4792 diff changeset	523 (let ((skip (or (looking-at "((")
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	524 ;; 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	525 (looking-at "(prog[nv12\$ress-feedback\\\|n-with-message\$]")
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	526 (looking-at "(unwind-protect ")
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	527 (looking-at "(function (")
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	528 (looking-at "(cl-block-wrapper ")))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	529 (two (or (looking-at "(defun ") (looking-at "(defmacro ")))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	530 (let (or (looking-at "(let\\*? ") (looking-at "(while ")))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	531 (set (looking-at "(p?set[qf] ")))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	532 (if (or skip let
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	533 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	534 (forward-sexp)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	535 (and (>= (current-column) 78) (progn (backward-sexp) t))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	536 (let ((nl t))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	537 (forward-char 1)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	538 (cl-do-prettyprint)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	539 (or skip (looking-at ")") (cl-do-prettyprint))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	540 (or (not two) (looking-at ")") (cl-do-prettyprint))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	541 (while (not (looking-at ")"))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	542 (if set (setq nl (not nl)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	543 (if nl (insert "\n"))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	544 (lisp-indent-line)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	545 (cl-do-prettyprint))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	546 (forward-char 1))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	547 (forward-sexp)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	548
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	549 (defvar cl-macroexpand-cmacs nil)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	550 (defvar cl-closure-vars nil)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	551
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	552 (defun cl-macroexpand-all (form &optional env)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	553 "Expand all macro calls through a Lisp FORM.
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	554 This also does some trivial optimizations to make the form prettier."
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	555 (while (or (not (eq form (setq form (macroexpand form env))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	556 (and cl-macroexpand-cmacs
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	557 (not (eq form (setq form (compiler-macroexpand form)))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	558 (cond ((not (consp form)) form)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	559 ((memq (car form) '(let let*))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	560 (if (null (nth 1 form))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	561 (cl-macroexpand-all (cons 'progn (cddr form)) env)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	562 (let ((letf nil) (res nil) (lets (cadr form)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	563 (while lets
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	564 (push (if (consp (car lets))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	565 (let ((exp (cl-macroexpand-all (caar lets) env)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	566 (or (symbolp exp) (setq letf t))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	567 (cons exp (cl-macroexpand-body (cdar lets) env)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	568 (let ((exp (cl-macroexpand-all (car lets) env)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	569 (if (symbolp exp) exp
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	570 (setq letf t) (list exp nil)))) res)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	571 (setq lets (cdr lets)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	572 (list* (if letf (if (eq (car form) 'let) 'letf 'letf*) (car form))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	573 (nreverse res) (cl-macroexpand-body (cddr form) env)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	574 ((eq (car form) 'cond)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	575 (cons (car form)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	576 (mapcar (function (lambda (x) (cl-macroexpand-body x env)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	577 (cdr form))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	578 ((eq (car form) 'condition-case)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	579 (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	580 (mapcar (function
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	581 (lambda (x)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	582 (cons (car x) (cl-macroexpand-body (cdr x) env))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	583 (cdddr form))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	584 ((memq (car form) '(quote function))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	585 (if (eq (car-safe (nth 1 form)) 'lambda)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	586 (let ((body (cl-macroexpand-body (cddadr form) env)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	587 (if (and cl-closure-vars (eq (car form) 'function)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	588 (cl-expr-contains-any body cl-closure-vars))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	589 (let* ((new (mapcar 'gensym cl-closure-vars))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	590 (sub (pairlis cl-closure-vars new)) (decls nil))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	591 (while (or (stringp (car body))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	592 (eq (car-safe (car body)) 'interactive))
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	593 (push (list 'quote (pop body)) decls))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	594 (put (car (last cl-closure-vars)) 'used t)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	595 (append
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	596 (list 'list '(quote lambda) '(quote (&rest --cl-rest--)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	597 (sublis sub (nreverse decls))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	598 (list
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	599 (list* 'list '(quote apply)
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	600 ;; XEmacs: put a quote before the function
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	601 (list 'list '(quote quote)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	602 (list 'function
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	603 (list* 'lambda
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	604 (append new (cadadr form))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	605 (sublis sub body))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	606 (nconc (mapcar (function
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	607 (lambda (x)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	608 (list 'list '(quote quote) x)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	609 cl-closure-vars)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	610 '((quote --cl-rest--)))))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	611 (list (car form) (list* 'lambda (cadadr form) body))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	612 (let ((found (assq (cadr form) env)))
5353 38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5339 diff changeset	613 ;; XEmacs: cadr/caddr operate on nil without errors. But the
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5339 diff changeset	614 ;; macro definition may be compiled, in which case there's
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5339 diff changeset	615 ;; nothing for us to do.
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5339 diff changeset	616 (if (and (listp (cdr found))
38e24b8be4ea Improve the lexical scoping in #'block, #'return-from. Aidan Kehoe <kehoea@parhasard.net> parents: 5339 diff changeset	617 (eq (cadr (caddr found)) 'cl-labels-args))
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	618 (cl-macroexpand-all (cadr (caddr (cadddr found))) env)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	619 form))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	620 ((memq (car form) '(defun defmacro))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	621 (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	622 ((and (eq (car form) 'progn) (not (cddr form)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	623 (cl-macroexpand-all (nth 1 form) env))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	624 ((eq (car form) 'setq)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	625 (let* ((args (cl-macroexpand-body (cdr form) env)) (p args))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	626 (while (and p (symbolp (car p))) (setq p (cddr p)))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	627 (if p (cl-macroexpand-all (cons 'setf args)) (cons 'setq args))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	628 (t (cons (car form) (cl-macroexpand-body (cdr form) env)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	629
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	630 (defun cl-macroexpand-body (body &optional env)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	631 (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	632
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	633 (defun cl-prettyexpand (form &optional full)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	634 (message "Expanding...")
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	635 (let ((cl-macroexpand-cmacs full) (cl-compiling-file full)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	636 (byte-compile-macro-environment nil))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	637 (setq form (cl-macroexpand-all form
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	638 (and (not full) '((block) (eval-when)))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	639 (message "Formatting...")
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	640 (prog1 (cl-prettyprint form)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	641 (message ""))))
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	642
5284 d27c1ee1943b Make the order of preloaded-file-list more sane. Aidan Kehoe <kehoea@parhasard.net> parents: 5273 diff changeset	643 ;; 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	644 ;; 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	645 ;; 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	646 (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	647
5387 5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	648 ;; 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	649
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	650 ;; 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	651 (labels
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs Aidan Kehoe <kehoea@parhasard.net> parents: 5353 diff changeset	652 ((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	653 (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	654 (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	655 (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	656 (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	657 (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	658 (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	659 (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	660 ;; 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	661 (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	662 (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	663 (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	664 (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	665 ;; 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	666 (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	667 (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	668 (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	669 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	670 ;; 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	671 (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	672 (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	673 (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	674 (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	675 (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	676 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	677 ;; 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	678 (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	679 (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	680 (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	681 (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	682 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	683 (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	684 (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	685 (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	686 (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	687 (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	688 (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	689 (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	690
5400 aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	691 ;; No type-checking here, we should add it.
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	692 (defalias 'char< '<)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	693 (defalias 'char>= '>=)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	694 (defalias 'char> '>)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	695 (defalias 'char<= '<=)
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.
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	698 (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	699 "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	700
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	701 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	702 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	703 (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	704 (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	705 (if (<= radix 10)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	706 (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	707 (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	708 (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	709 (+ character (- 10 ?a)))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	710 (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	711 (+ character (- 10 ?A))))))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	712
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	713 (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	714 "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	715
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	716 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	717 (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	718 (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	719 (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	720 (if (< weight 10)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	721 (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	722 (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	723
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	724 (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	725 "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	726
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	727 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	728 (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	729 (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	730 (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	731
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	732 (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	733 "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	734
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	735 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	736 ?\\x9f, inclusive."
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	737 (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	738 (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	739
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	740 (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	741 "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	742
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	743 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	744 (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	745 (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	746
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	747 (symbol-macrolet
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	748 ((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	749 (?\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	750 (?\x7f . "Rubout"))))
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 (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	753 "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	754
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	755 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	756 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	757 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	758 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	759 (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	760 (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	761 (let ((unicode-data
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	762 (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	763 (and unicode-data
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	764 (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	765 (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	766 (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	767
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	768 (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	769 "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	770 (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	771 (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	772 (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	773 (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	774 (require 'descr-text)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	775 (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	776 ;; Don't use -literally in case of DOS line endings.
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	777 (insert-file-contents describe-char-unicodedata-file))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	778 (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	779 (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	780 (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	781 (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	782 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	783 (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	784
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	785 (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	786 "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	787 (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	788 (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	789 (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	790
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	791 (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	792 "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	793 (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	794 (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	795 (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	796
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	797 (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	798 "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	799 (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	800 (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	801 (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	802 (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	803
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	804 (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	805 "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	806 Otherwise, return CHARACTER."
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	807 (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	808 (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	809
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	810 (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	811 "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	812 Otherwise, return CHARACTER."
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	813 (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	814 (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	815
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	816 (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	817 "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	818 (ecase (signum integer)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	819 (0 0)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier. Aidan Kehoe <kehoea@parhasard.net> parents: 5387 diff changeset	820 (-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	821 (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	822
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	823 (run-hooks 'cl-extra-load-hook)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	824
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	825 ;; XEmacs addition
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	826 (provide 'cl-extra)
3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	827
2153 393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james] james parents: 1983 diff changeset	828 ;;; arch-tag: bcd03437-0871-43fb-a8f1-ad0e0b5427ed
428 3ecd8885ac67 Import from CVS: tag r21-2-22 cvs parents: diff changeset	829 ;;; cl-extra.el ends here

Mercurial > hg > xemacs-beta

annotate lisp/cl-extra.el @ 5475:248176c74e6b