Mercurial > hg > xemacs-beta
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 |
rev | line source |
---|---|
613 | 1 ;;; cl-extra.el --- Common Lisp extensions for XEmacs Lisp (part two) |
428 | 2 |
2153 | 3 ;; Copyright (C) 1993,2000,2003 Free Software Foundation, Inc. |
801 | 4 ;; Copyright (C) 2002 Ben Wing. |
428 | 5 |
6 ;; Author: Dave Gillespie <daveg@synaptics.com> | |
7 ;; Maintainer: XEmacs Development Team | |
8 ;; Version: 2.02 | |
9 ;; Keywords: extensions, dumped | |
10 | |
11 ;; This file is part of XEmacs. | |
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 | 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 | 22 |
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 | 25 |
2153 | 26 ;;; Synched up with: FSF 21.3. |
428 | 27 |
28 ;;; Commentary: | |
29 | |
30 ;; This file is dumped with XEmacs. | |
31 | |
32 ;; These are extensions to Emacs Lisp that provide a degree of | |
33 ;; Common Lisp compatibility, beyond what is already built-in | |
34 ;; in Emacs Lisp. | |
35 ;; | |
36 ;; This package was written by Dave Gillespie; it is a complete | |
37 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986. | |
38 ;; | |
39 ;; Bug reports, comments, and suggestions are welcome! | |
40 | |
41 ;; This file contains portions of the Common Lisp extensions | |
42 ;; package which are autoloaded since they are relatively obscure. | |
43 | |
44 ;; See cl.el for Change Log. | |
45 | |
46 | |
47 ;;; Code: | |
2153 | 48 ;; XEmacs addition |
428 | 49 (eval-when-compile |
50 (require 'obsolete)) | |
51 | |
52 ;;; Type coercion. | |
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 | 55 "Coerce OBJECT to type TYPE. |
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 | 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 | 70 ;; XEmacs addition: enhanced numeric type coercions |
2367 | 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 | 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 | 80 ;; XEmacs addition: weak-list coercion |
428 | 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 | 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 | 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 | 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 | 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 | 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 | 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 | 146 |
147 ;;; Support for `loop'. | |
2153 | 148 (defalias 'cl-map-keymap 'map-keymap) |
428 | 149 |
150 (defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base) | |
151 (or cl-base | |
2153 | 152 (setq cl-base (copy-sequence [0]))) |
153 (map-keymap | |
428 | 154 (function |
155 (lambda (cl-key cl-bind) | |
156 (aset cl-base (1- (length cl-base)) cl-key) | |
157 (if (keymapp cl-bind) | |
158 (cl-map-keymap-recursively | |
159 cl-func-rec cl-bind | |
2153 | 160 (vconcat cl-base (list 0))) |
428 | 161 (funcall cl-func-rec cl-base cl-bind)))) |
162 cl-map)) | |
163 | |
164 (defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end) | |
165 (or cl-what (setq cl-what (current-buffer))) | |
166 (if (bufferp cl-what) | |
167 (let (cl-mark cl-mark2 (cl-next t) cl-next2) | |
2153 | 168 (with-current-buffer cl-what |
428 | 169 (setq cl-mark (copy-marker (or cl-start (point-min)))) |
170 (setq cl-mark2 (and cl-end (copy-marker cl-end)))) | |
171 (while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2))) | |
2153 | 172 (setq cl-next (if cl-prop (next-single-property-change |
173 cl-mark cl-prop cl-what) | |
174 (next-property-change cl-mark cl-what)) | |
175 cl-next2 (or cl-next (with-current-buffer cl-what | |
176 (point-max)))) | |
428 | 177 (funcall cl-func (prog1 (marker-position cl-mark) |
178 (set-marker cl-mark cl-next2)) | |
179 (if cl-mark2 (min cl-next2 cl-mark2) cl-next2))) | |
180 (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil))) | |
181 (or cl-start (setq cl-start 0)) | |
182 (or cl-end (setq cl-end (length cl-what))) | |
183 (while (< cl-start cl-end) | |
2153 | 184 (let ((cl-next (or (if cl-prop (next-single-property-change |
185 cl-start cl-prop cl-what) | |
186 (next-property-change cl-start cl-what)) | |
428 | 187 cl-end))) |
188 (funcall cl-func cl-start (min cl-next cl-end)) | |
189 (setq cl-start cl-next))))) | |
190 | |
191 (defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg) | |
192 (or cl-buffer (setq cl-buffer (current-buffer))) | |
502 | 193 (with-fboundp '(overlay-start overlay-end overlays-at next-overlay-change) |
194 (if-fboundp 'overlay-lists | |
428 | 195 |
502 | 196 ;; This is the preferred algorithm, though overlay-lists is |
197 ;; undocumented. | |
198 (let (cl-ovl) | |
2153 | 199 (with-current-buffer cl-buffer |
502 | 200 (setq cl-ovl (overlay-lists)) |
201 (if cl-start (setq cl-start (copy-marker cl-start))) | |
202 (if cl-end (setq cl-end (copy-marker cl-end)))) | |
203 (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl))) | |
204 (while (and cl-ovl | |
205 (or (not (overlay-start (car cl-ovl))) | |
206 (and cl-end (>= (overlay-start (car cl-ovl)) cl-end)) | |
207 (and cl-start (<= (overlay-end (car cl-ovl)) | |
208 cl-start)) | |
209 (not (funcall cl-func (car cl-ovl) cl-arg)))) | |
210 (setq cl-ovl (cdr cl-ovl))) | |
211 (if cl-start (set-marker cl-start nil)) | |
212 (if cl-end (set-marker cl-end nil))) | |
213 | |
214 ;; This alternate algorithm fails to find zero-length overlays. | |
2153 | 215 (let ((cl-mark (with-current-buffer cl-buffer |
216 (copy-marker (or cl-start (point-min))))) | |
217 (cl-mark2 (and cl-end (with-current-buffer cl-buffer | |
218 (copy-marker cl-end)))) | |
502 | 219 cl-pos cl-ovl) |
220 (while (save-excursion | |
221 (and (setq cl-pos (marker-position cl-mark)) | |
222 (< cl-pos (or cl-mark2 (point-max))) | |
223 (progn | |
224 (set-buffer cl-buffer) | |
225 (setq cl-ovl (overlays-at cl-pos)) | |
226 (set-marker cl-mark (next-overlay-change cl-pos))))) | |
227 (while (and cl-ovl | |
228 (or (/= (overlay-start (car cl-ovl)) cl-pos) | |
229 (not (and (funcall cl-func (car cl-ovl) cl-arg) | |
230 (set-marker cl-mark nil))))) | |
231 (setq cl-ovl (cdr cl-ovl)))) | |
232 (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))))) | |
428 | 233 |
234 ;;; Support for `setf'. | |
235 (defun cl-set-frame-visible-p (frame val) | |
236 (cond ((null val) (make-frame-invisible frame)) | |
237 ((eq val 'icon) (iconify-frame frame)) | |
238 (t (make-frame-visible frame))) | |
239 val) | |
240 | |
241 ;;; Support for `progv'. | |
242 (defvar cl-progv-save) | |
243 (defun cl-progv-before (syms values) | |
244 (while syms | |
2153 | 245 (push (if (boundp (car syms)) |
428 | 246 (cons (car syms) (symbol-value (car syms))) |
247 (car syms)) cl-progv-save) | |
248 (if values | |
2153 | 249 (set (pop syms) (pop values)) |
250 (makunbound (pop syms))))) | |
428 | 251 |
252 (defun cl-progv-after () | |
253 (while cl-progv-save | |
254 (if (consp (car cl-progv-save)) | |
255 (set (car (car cl-progv-save)) (cdr (car cl-progv-save))) | |
256 (makunbound (car cl-progv-save))) | |
2153 | 257 (pop cl-progv-save))) |
428 | 258 |
259 ;;; Numbers. | |
260 | |
261 (defun gcd (&rest args) | |
262 "Return the greatest common divisor of the arguments." | |
2153 | 263 (let ((a (abs (or (pop args) 0)))) |
428 | 264 (while args |
2153 | 265 (let ((b (abs (pop args)))) |
428 | 266 (while (> b 0) (setq b (% a (setq a b)))))) |
267 a)) | |
268 | |
269 (defun lcm (&rest args) | |
270 "Return the least common multiple of the arguments." | |
271 (if (memq 0 args) | |
272 0 | |
2153 | 273 (let ((a (abs (or (pop args) 1)))) |
428 | 274 (while args |
2153 | 275 (let ((b (abs (pop args)))) |
428 | 276 (setq a (* (/ a (gcd a b)) b)))) |
277 a))) | |
278 | |
279 (defun isqrt (a) | |
280 "Return the integer square root of the argument." | |
281 (if (and (integerp a) (> a 0)) | |
282 ;; XEmacs change | |
283 (let ((g (cond ((>= a 1000000) 10000) ((>= a 10000) 1000) | |
284 ((>= a 100) 100) (t 10))) | |
285 g2) | |
286 (while (< (setq g2 (/ (+ g (/ a g)) 2)) g) | |
287 (setq g g2)) | |
288 g) | |
289 (if (eq a 0) 0 (signal 'arith-error nil)))) | |
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 | 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 | 313 |
314 (defun mod* (x y) | |
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 | 317 |
318 (defun rem* (x y) | |
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 | 321 |
322 (defun signum (a) | |
323 "Return 1 if A is positive, -1 if negative, 0 if zero." | |
324 (cond ((> a 0) 1) ((< a 0) -1) (t 0))) | |
325 | |
326 ;; Random numbers. | |
327 | |
328 (defvar *random-state*) | |
329 (defun random* (lim &optional state) | |
330 "Return a random nonnegative number less than LIM, an integer or float. | |
331 Optional second arg STATE is a random-state object." | |
332 (or state (setq state *random-state*)) | |
333 ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method. | |
334 (let ((vec (aref state 3))) | |
335 (if (integerp vec) | |
336 (let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1)) | |
337 (aset state 3 (setq vec (make-vector 55 nil))) | |
338 (aset vec 0 j) | |
339 (while (> (setq i (% (+ i 21) 55)) 0) | |
340 (aset vec i (setq j (prog1 k (setq k (- j k)))))) | |
341 (while (< (setq i (1+ i)) 200) (random* 2 state)))) | |
342 (let* ((i (aset state 1 (% (1+ (aref state 1)) 55))) | |
343 (j (aset state 2 (% (1+ (aref state 2)) 55))) | |
344 (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j)))))) | |
345 (if (integerp lim) | |
346 (if (<= lim 512) (% n lim) | |
347 (if (> lim 8388607) (setq n (+ (lsh n 9) (random* 512 state)))) | |
348 (let ((mask 1023)) | |
349 (while (< mask (1- lim)) (setq mask (1+ (+ mask mask)))) | |
350 (if (< (setq n (logand n mask)) lim) n (random* lim state)))) | |
351 (* (/ n '8388608e0) lim))))) | |
352 | |
353 (defun make-random-state (&optional state) | |
354 "Return a copy of random-state STATE, or of `*random-state*' if omitted. | |
355 If STATE is t, return a new state object seeded from the time of day." | |
356 (cond ((null state) (make-random-state *random-state*)) | |
357 ((vectorp state) (cl-copy-tree state t)) | |
358 ((integerp state) (vector 'cl-random-state-tag -1 30 state)) | |
359 (t (make-random-state (cl-random-time))))) | |
360 | |
361 (defun random-state-p (object) | |
362 "Return t if OBJECT is a random-state object." | |
363 (and (vectorp object) (= (length object) 4) | |
364 (eq (aref object 0) 'cl-random-state-tag))) | |
365 | |
366 ;;; Sequence functions. | |
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 | 369 |
370 (defun concatenate (type &rest seqs) | |
371 "Concatenate, into a sequence of type TYPE, the argument SEQUENCES." | |
2153 | 372 ;; XEmacs change: use case instead of cond for clarity |
428 | 373 (case type |
374 (vector (apply 'vconcat seqs)) | |
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 | 379 |
380 ;;; List functions. | |
381 | |
382 (defun revappend (x y) | |
383 "Equivalent to (append (reverse X) Y)." | |
384 (nconc (reverse x) y)) | |
385 | |
386 (defun nreconc (x y) | |
387 "Equivalent to (nconc (nreverse X) Y)." | |
388 (nconc (nreverse x) y)) | |
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 | 391 (defun tailp (sublist list) |
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 | 401 |
2153 | 402 (defalias 'cl-copy-tree 'copy-tree) |
428 | 403 |
404 ;;; Property lists. | |
405 | |
406 ;; XEmacs: our `get' groks DEFAULT. | |
407 (defalias 'get* 'get) | |
442 | 408 (defalias 'getf 'plist-get) |
428 | 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 | 413 (defalias 'cl-remprop 'remprop) |
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 | 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 | 454 |
428 | 455 ;;; Hash tables. |
456 | |
457 ;; The `regular' Common Lisp hash-table stuff has been moved into C. | |
458 ;; Only backward compatibility stuff remains here. | |
459 (defun make-hashtable (size &optional test) | |
460 (make-hash-table :test test :size size)) | |
461 (defun make-weak-hashtable (size &optional test) | |
462 (make-hash-table :test test :size size :weakness t)) | |
463 (defun make-key-weak-hashtable (size &optional test) | |
464 (make-hash-table :test test :size size :weakness 'key)) | |
465 (defun make-value-weak-hashtable (size &optional test) | |
466 (make-hash-table :test test :size size :weakness 'value)) | |
467 | |
468 (define-obsolete-function-alias 'hashtablep 'hash-table-p) | |
469 (define-obsolete-function-alias 'hashtable-fullness 'hash-table-count) | |
470 (define-obsolete-function-alias 'hashtable-test-function 'hash-table-test) | |
471 (define-obsolete-function-alias 'hashtable-type 'hash-table-type) | |
472 (define-obsolete-function-alias 'hashtable-size 'hash-table-size) | |
473 (define-obsolete-function-alias 'copy-hashtable 'copy-hash-table) | |
474 | |
475 (make-obsolete 'make-hashtable 'make-hash-table) | |
476 (make-obsolete 'make-weak-hashtable 'make-hash-table) | |
477 (make-obsolete 'make-key-weak-hashtable 'make-hash-table) | |
478 (make-obsolete 'make-value-weak-hashtable 'make-hash-table) | |
479 (make-obsolete 'hash-table-type 'hash-table-weakness) | |
480 | |
481 (when (fboundp 'x-keysym-hash-table) | |
482 (make-obsolete 'x-keysym-hashtable 'x-keysym-hash-table)) | |
483 | |
484 ;; Compatibility stuff for old kludgy cl.el hash table implementation | |
485 (defvar cl-builtin-gethash (symbol-function 'gethash)) | |
486 (defvar cl-builtin-remhash (symbol-function 'remhash)) | |
487 (defvar cl-builtin-clrhash (symbol-function 'clrhash)) | |
488 (defvar cl-builtin-maphash (symbol-function 'maphash)) | |
489 | |
490 (defalias 'cl-gethash 'gethash) | |
491 (defalias 'cl-puthash 'puthash) | |
492 (defalias 'cl-remhash 'remhash) | |
493 (defalias 'cl-clrhash 'clrhash) | |
494 (defalias 'cl-maphash 'maphash) | |
2153 | 495 ;; These three actually didn't exist in Emacs-20. |
496 (defalias 'cl-make-hash-table 'make-hash-table) | |
497 (defalias 'cl-hash-table-p 'hash-table-p) | |
498 (defalias 'cl-hash-table-count 'hash-table-count) | |
428 | 499 |
500 ;;; Some debugging aids. | |
501 | |
502 (defun cl-prettyprint (form) | |
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 | 505 (insert "\n" (prin1-to-string form) "\n") |
506 (setq last (point)) | |
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 | 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 | 517 (goto-char (1+ pt)) |
518 (cl-do-prettyprint))) | |
519 | |
520 (defun cl-do-prettyprint () | |
521 (skip-chars-forward " ") | |
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 | 524 ;; XEmacs: be selective about trailing stuff after prog |
1729 | 525 (looking-at "(prog[nv12\\(ress-feedback\\|n-with-message\\)]") |
428 | 526 (looking-at "(unwind-protect ") |
527 (looking-at "(function (") | |
528 (looking-at "(cl-block-wrapper "))) | |
529 (two (or (looking-at "(defun ") (looking-at "(defmacro "))) | |
530 (let (or (looking-at "(let\\*? ") (looking-at "(while "))) | |
531 (set (looking-at "(p?set[qf] "))) | |
532 (if (or skip let | |
533 (progn | |
534 (forward-sexp) | |
535 (and (>= (current-column) 78) (progn (backward-sexp) t)))) | |
536 (let ((nl t)) | |
537 (forward-char 1) | |
538 (cl-do-prettyprint) | |
539 (or skip (looking-at ")") (cl-do-prettyprint)) | |
540 (or (not two) (looking-at ")") (cl-do-prettyprint)) | |
541 (while (not (looking-at ")")) | |
542 (if set (setq nl (not nl))) | |
543 (if nl (insert "\n")) | |
544 (lisp-indent-line) | |
545 (cl-do-prettyprint)) | |
546 (forward-char 1)))) | |
547 (forward-sexp))) | |
548 | |
549 (defvar cl-macroexpand-cmacs nil) | |
550 (defvar cl-closure-vars nil) | |
551 | |
552 (defun cl-macroexpand-all (form &optional env) | |
553 "Expand all macro calls through a Lisp FORM. | |
554 This also does some trivial optimizations to make the form prettier." | |
555 (while (or (not (eq form (setq form (macroexpand form env)))) | |
556 (and cl-macroexpand-cmacs | |
557 (not (eq form (setq form (compiler-macroexpand form))))))) | |
558 (cond ((not (consp form)) form) | |
559 ((memq (car form) '(let let*)) | |
560 (if (null (nth 1 form)) | |
561 (cl-macroexpand-all (cons 'progn (cddr form)) env) | |
562 (let ((letf nil) (res nil) (lets (cadr form))) | |
563 (while lets | |
2153 | 564 (push (if (consp (car lets)) |
428 | 565 (let ((exp (cl-macroexpand-all (caar lets) env))) |
566 (or (symbolp exp) (setq letf t)) | |
567 (cons exp (cl-macroexpand-body (cdar lets) env))) | |
568 (let ((exp (cl-macroexpand-all (car lets) env))) | |
569 (if (symbolp exp) exp | |
570 (setq letf t) (list exp nil)))) res) | |
571 (setq lets (cdr lets))) | |
572 (list* (if letf (if (eq (car form) 'let) 'letf 'letf*) (car form)) | |
573 (nreverse res) (cl-macroexpand-body (cddr form) env))))) | |
574 ((eq (car form) 'cond) | |
575 (cons (car form) | |
576 (mapcar (function (lambda (x) (cl-macroexpand-body x env))) | |
577 (cdr form)))) | |
578 ((eq (car form) 'condition-case) | |
579 (list* (car form) (nth 1 form) (cl-macroexpand-all (nth 2 form) env) | |
580 (mapcar (function | |
581 (lambda (x) | |
582 (cons (car x) (cl-macroexpand-body (cdr x) env)))) | |
583 (cdddr form)))) | |
584 ((memq (car form) '(quote function)) | |
585 (if (eq (car-safe (nth 1 form)) 'lambda) | |
586 (let ((body (cl-macroexpand-body (cddadr form) env))) | |
587 (if (and cl-closure-vars (eq (car form) 'function) | |
588 (cl-expr-contains-any body cl-closure-vars)) | |
589 (let* ((new (mapcar 'gensym cl-closure-vars)) | |
590 (sub (pairlis cl-closure-vars new)) (decls nil)) | |
591 (while (or (stringp (car body)) | |
592 (eq (car-safe (car body)) 'interactive)) | |
2153 | 593 (push (list 'quote (pop body)) decls)) |
428 | 594 (put (car (last cl-closure-vars)) 'used t) |
595 (append | |
596 (list 'list '(quote lambda) '(quote (&rest --cl-rest--))) | |
597 (sublis sub (nreverse decls)) | |
598 (list | |
599 (list* 'list '(quote apply) | |
2153 | 600 ;; XEmacs: put a quote before the function |
428 | 601 (list 'list '(quote quote) |
602 (list 'function | |
603 (list* 'lambda | |
604 (append new (cadadr form)) | |
605 (sublis sub body)))) | |
606 (nconc (mapcar (function | |
607 (lambda (x) | |
608 (list 'list '(quote quote) x))) | |
609 cl-closure-vars) | |
610 '((quote --cl-rest--))))))) | |
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 | 627 form)))) |
628 ((memq (car form) '(defun defmacro)) | |
629 (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env))) | |
630 ((and (eq (car form) 'progn) (not (cddr form))) | |
631 (cl-macroexpand-all (nth 1 form) env)) | |
632 ((eq (car form) 'setq) | |
633 (let* ((args (cl-macroexpand-body (cdr form) env)) (p args)) | |
634 (while (and p (symbolp (car p))) (setq p (cddr p))) | |
635 (if p (cl-macroexpand-all (cons 'setf args)) (cons 'setq args)))) | |
636 (t (cons (car form) (cl-macroexpand-body (cdr form) env))))) | |
637 | |
638 (defun cl-macroexpand-body (body &optional env) | |
639 (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body)) | |
640 | |
641 (defun cl-prettyexpand (form &optional full) | |
642 (message "Expanding...") | |
643 (let ((cl-macroexpand-cmacs full) (cl-compiling-file full) | |
644 (byte-compile-macro-environment nil)) | |
645 (setq form (cl-macroexpand-all form | |
646 (and (not full) '((block) (eval-when))))) | |
647 (message "Formatting...") | |
648 (prog1 (cl-prettyprint form) | |
649 (message "")))) | |
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 | 877 (run-hooks 'cl-extra-load-hook) |
878 | |
2153 | 879 ;; XEmacs addition |
428 | 880 (provide 'cl-extra) |
881 | |
2153 | 882 ;;; arch-tag: bcd03437-0871-43fb-a8f1-ad0e0b5427ed |
428 | 883 ;;; cl-extra.el ends here |