annotate lisp/cl-extra.el @ 5574:d4f334808463

Support inlining labels, bytecomp.el. lisp/ChangeLog addition: 2011-10-02 Aidan Kehoe <kehoea@parhasard.net> * bytecomp.el (byte-compile-initial-macro-environment): Add #'declare to this, so it doesn't need to rely on #'cl-compiling file to determine when we're byte-compiling. Update #'labels to support declaring labels inline, as Common Lisp requires. * bytecomp.el (byte-compile-function-form): Don't error if FUNCTION is quoting a non-lambda, non-symbol, just return it. * cl-extra.el (cl-macroexpand-all): If a label name has been quoted, expand to the label placeholder quoted with 'function. This allows the byte compiler to distinguish between uses of the placeholder as data and uses in contexts where it should be inlined. * cl-macs.el: * cl-macs.el (cl-do-proclaim): When proclaming something as inline, if it is bound as a label, don't modify the symbol's plist; instead, treat the first element of its placeholder constant vector as a place to store compile information. * cl-macs.el (declare): Leave processing declarations while compiling to the implementation of #'declare in byte-compile-initial-macro-environment. tests/ChangeLog addition: 2011-10-02 Aidan Kehoe <kehoea@parhasard.net> * automated/lisp-tests.el: * automated/lisp-tests.el (+): Test #'labels and inlining.
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 02 Oct 2011 15:32:16 +0100
parents 855b667dea13
children 10f179710250
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
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))))
5562
855b667dea13 Drop cl-macro-environment in favour of byte-compile-macro-environment.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5476
diff changeset
612 ;; This is a bit of a hack; special-case symbols with bindings as
855b667dea13 Drop cl-macro-environment in favour of byte-compile-macro-environment.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5476
diff changeset
613 ;; labels.
855b667dea13 Drop cl-macro-environment in favour of byte-compile-macro-environment.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5476
diff changeset
614 (let ((found (cdr (assq (cadr form) env))))
855b667dea13 Drop cl-macro-environment in favour of byte-compile-macro-environment.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5476
diff changeset
615 (if (and (consp found) (eq (nth 1 (nth 1 found)) 'cl-labels-args))
855b667dea13 Drop cl-macro-environment in favour of byte-compile-macro-environment.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5476
diff changeset
616 (if (consp (nth 2 (nth 2 found)))
855b667dea13 Drop cl-macro-environment in favour of byte-compile-macro-environment.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5476
diff changeset
617 ;; It's a cons; this is the implementation of
855b667dea13 Drop cl-macro-environment in favour of byte-compile-macro-environment.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5476
diff changeset
618 ;; labels in cl-macs.el.
855b667dea13 Drop cl-macro-environment in favour of byte-compile-macro-environment.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5476
diff changeset
619 (cl-macroexpand-all (nth 1 (nth 2 (nth 2 found))) env)
855b667dea13 Drop cl-macro-environment in favour of byte-compile-macro-environment.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5476
diff changeset
620 ;; It's an atom, almost certainly a compiled function;
855b667dea13 Drop cl-macro-environment in favour of byte-compile-macro-environment.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5476
diff changeset
621 ;; we're using the implementation of labels in
5574
d4f334808463 Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5562
diff changeset
622 ;; bytecomp.el. Quote it with FUNCTION so that code can
d4f334808463 Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5562
diff changeset
623 ;; tell uses as data apart from the uses with funcall,
d4f334808463 Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5562
diff changeset
624 ;; where it's unquoted. #### We should warn if (car form)
d4f334808463 Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5562
diff changeset
625 ;; above is quote, rather than function.
d4f334808463 Support inlining labels, bytecomp.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5562
diff changeset
626 (list 'function (nth 2 (nth 2 found))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
627 form))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
628 ((memq (car form) '(defun defmacro))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
629 (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
630 ((and (eq (car form) 'progn) (not (cddr form)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
631 (cl-macroexpand-all (nth 1 form) env))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
632 ((eq (car form) 'setq)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
633 (let* ((args (cl-macroexpand-body (cdr form) env)) (p args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
634 (while (and p (symbolp (car p))) (setq p (cddr p)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
635 (if p (cl-macroexpand-all (cons 'setf args)) (cons 'setq args))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
636 (t (cons (car form) (cl-macroexpand-body (cdr form) env)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
637
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
638 (defun cl-macroexpand-body (body &optional env)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
639 (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
640
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
641 (defun cl-prettyexpand (form &optional full)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
642 (message "Expanding...")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
643 (let ((cl-macroexpand-cmacs full) (cl-compiling-file full)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
644 (byte-compile-macro-environment nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
645 (setq form (cl-macroexpand-all form
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
646 (and (not full) '((block) (eval-when)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
647 (message "Formatting...")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
648 (prog1 (cl-prettyprint form)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
649 (message ""))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
650
5284
d27c1ee1943b Make the order of preloaded-file-list more sane.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5273
diff changeset
651 ;; 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
652 ;; 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
653 ;; 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
654 (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
655
5387
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs
Aidan Kehoe <kehoea@parhasard.net>
parents: 5353
diff changeset
656 ;; 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
657
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs
Aidan Kehoe <kehoea@parhasard.net>
parents: 5353
diff changeset
658 ;; 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
659 (labels
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs
Aidan Kehoe <kehoea@parhasard.net>
parents: 5353
diff changeset
660 ((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
661 (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
662 (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
663 (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
664 (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
665 (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
666 (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
667 (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
668 ;; 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
669 (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
670 (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
671 (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
672 (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
673 ;; 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
674 (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
675 (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
676 (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
677 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
678 ;; 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
679 (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
680 (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
681 (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
682 (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
683 (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
684 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
685 ;; 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
686 (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
687 (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
688 (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
689 (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
690 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
691 (setq x 1e0)
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs
Aidan Kehoe <kehoea@parhasard.net>
parents: 5353
diff changeset
692 (while (/= (+ 1e0 x) 1e0) (setq x (/ x 2)))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs
Aidan Kehoe <kehoea@parhasard.net>
parents: 5353
diff changeset
693 (setq float-epsilon (* x 2))
5f5d48053e86 Drop #'cl-finite-do, defalias #'cl-float-limits to #'ignore in dumped XEmacs
Aidan Kehoe <kehoea@parhasard.net>
parents: 5353
diff changeset
694 (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
695 (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
696 (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
697 (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
698
5400
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
699
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
700 ;;; Character functions.
5461
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
701 (macrolet
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
702 ((define-char-comparisons (&rest alist)
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
703 "Provide Common Lisp's character-specific comparison predicates.
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
704
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
705 These throw errors if any arguments are non-characters, conflicting with
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
706 typical emacs behavior. This is not the case if
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
707 `byte-compile-delete-errors' is non-nil; see the documentation of that
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
708 variable.
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
709
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
710 This doesn't include the case-insensitive comparisons, and it probably
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
711 should."
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
712 (let* ((functions (mapcar 'car alist))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
713 (map (mapcar #'(lambda (symbol)
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
714 `(,symbol .
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
715 ,(intern (substring (symbol-name symbol)
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
716 (length "char")))))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
717 functions)))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
718 `(progn
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
719 (mapc
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
720 (function*
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
721 (lambda ((function . cl-unsafe-comparison))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
722 (put function 'cl-unsafe-comparison cl-unsafe-comparison)
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
723 (put function 'cl-compiler-macro
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
724 #'(lambda (form &rest arguments)
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
725 (if byte-compile-delete-errors
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
726 (cons (get (car form) 'cl-unsafe-comparison)
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
727 (cdr form))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
728 form)))))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
729 ',map)
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
730 ,@(mapcar
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
731 (function*
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
732 (lambda ((function . documentation))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
733 `(defun ,function (character &rest more-characters)
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
734 ,documentation
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
735 (check-type character character)
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
736 (check-type more-characters
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
737 (satisfies (lambda (list)
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
738 (every 'characterp list))))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
739 (apply ',(cdr (assq function map))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
740 character more-characters))))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
741 alist)))))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
742 (define-char-comparisons
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
743 (char= . "Return t if all character arguments are the same object.")
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
744 (char/= . "Return t if no two character arguments are the same object.")
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
745 (char< . "Return t if the character arguments monotonically increase.")
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
746 (char> . "Return t if the character arguments monotonically decrease.")
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
747 (char<= . "Return t if the character arguments are monotonically \
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
748 nondecreasing.")
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
749 (char>= . "Return t if the character arguments are monotonically \
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
750 nonincreasing.")))
568ec109e73d Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5400
diff changeset
751
5400
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
752 (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
753 "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
754
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
755 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
756 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
757 (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
758 (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
759 (if (<= radix 10)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
760 (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
761 (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
762 (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
763 (+ character (- 10 ?a)))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
764 (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
765 (+ character (- 10 ?A))))))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
766
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
767 (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
768 "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
769
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
770 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
771 (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
772 (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
773 (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
774 (if (< weight 10)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
775 (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
776 (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
777
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
778 (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
779 "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
780
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
781 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
782 (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
783 (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
784 (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
785
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
786 (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
787 "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
788
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
789 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
790 ?\\x9f, inclusive."
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
791 (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
792 (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
793
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
794 (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
795 "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
796
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
797 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
798 (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
799 (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
800
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
801 (symbol-macrolet
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
802 ((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
803 (?\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
804 (?\x7f . "Rubout"))))
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
805
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
806 (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
807 "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
808
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
809 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
810 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
811 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
812 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
813 (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 (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
815 (let ((unicode-data
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
816 (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
817 (and unicode-data
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
818 (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
819 (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
820 (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
821
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
822 (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
823 "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
824 (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
825 (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
826 (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
827 (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
828 (require 'descr-text)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
829 (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
830 ;; 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
831 (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
832 (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
833 (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
834 (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
835 (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
836 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
837 (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
838
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
839 (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
840 "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
841 (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
842 (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
843 (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
844
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
845 (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
846 "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
847 (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
848 (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
849 (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
850
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
851 (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
852 "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
853 (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
854 (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
855 (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
856 (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
857
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
858 (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
859 "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
860 Otherwise, return CHARACTER."
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
861 (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
862 (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
863
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
864 (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
865 "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
866 Otherwise, return CHARACTER."
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
867 (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
868 (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
869
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
870 (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
871 "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
872 (ecase (signum integer)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
873 (0 0)
aa78b0b0b289 Add various Common Lisp character functions, making porting CL code easier.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5387
diff changeset
874 (-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
875 (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
876
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
877 (run-hooks 'cl-extra-load-hook)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
878
2153
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james]
james
parents: 1983
diff changeset
879 ;; XEmacs addition
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
880 (provide 'cl-extra)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
881
2153
393039450288 [xemacs-hg @ 2004-06-26 21:25:23 by james]
james
parents: 1983
diff changeset
882 ;;; arch-tag: bcd03437-0871-43fb-a8f1-ad0e0b5427ed
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
883 ;;; cl-extra.el ends here