Mercurial > hg > xemacs-beta
annotate lisp/cl-extra.el @ 4792:95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
lisp/ChangeLog addition:
2009-11-08 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (cl-string-vector-equalp)
(cl-bit-vector-vector-equalp, cl-vector-array-equalp)
(cl-hash-table-contents-equalp): New functions, to implement
equalp treating arrays with identical contents as equivalent, as
specified by Common Lisp.
(equalp): Revise this function to implement array equivalence,
and the hash-table equalp behaviour specified by CL.
* cl-macs.el (equalp): Add a compiler macro for this function,
used when one of the arguments is constant, and as such, its type
is known at compile time.
man/ChangeLog addition:
2009-11-08 Aidan Kehoe <kehoea@parhasard.net>
* lispref/objects.texi (Equality Predicates):
Document #'equalp here, as well as #'equal and #'eq.
tests/ChangeLog addition:
2009-12-31 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el:
Test much of the functionality of equalp; add a pointer to Paul
Dietz' ANSI test suite for this function, converted to Emacs
Lisp. Not including the tests themselves in XEmacs because who
owns the copyright on the files is unclear and the GCL people
didn't respond to my queries.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Thu, 31 Dec 2009 15:09:41 +0000 |
| parents | d0ea57eb3de4 |
| children | b828e06dbe38 |
| 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 | |
| 13 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 14 ;; under the terms of the GNU General Public License as published by | |
| 15 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 16 ;; any later version. | |
| 17 | |
| 18 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 21 ;; General Public License for more details. | |
| 22 | |
| 23 ;; You should have received a copy of the GNU General Public License | |
| 24 ;; along with XEmacs; see the file COPYING. If not, write to the Free | |
| 25 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA | |
| 26 ;; 02111-1307, USA. | |
| 27 | |
| 2153 | 28 ;;; Synched up with: FSF 21.3. |
| 428 | 29 |
| 30 ;;; Commentary: | |
| 31 | |
| 32 ;; This file is dumped with XEmacs. | |
| 33 | |
| 34 ;; These are extensions to Emacs Lisp that provide a degree of | |
| 35 ;; Common Lisp compatibility, beyond what is already built-in | |
| 36 ;; in Emacs Lisp. | |
| 37 ;; | |
| 38 ;; This package was written by Dave Gillespie; it is a complete | |
| 39 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986. | |
| 40 ;; | |
| 41 ;; Bug reports, comments, and suggestions are welcome! | |
| 42 | |
| 43 ;; This file contains portions of the Common Lisp extensions | |
| 44 ;; package which are autoloaded since they are relatively obscure. | |
| 45 | |
| 46 ;; See cl.el for Change Log. | |
| 47 | |
| 48 | |
| 49 ;;; Code: | |
| 2153 | 50 ;; XEmacs addition |
| 428 | 51 (eval-when-compile |
| 52 (require 'obsolete)) | |
| 53 | |
| 54 (or (memq 'cl-19 features) | |
| 55 (error "Tried to load `cl-extra' before `cl'!")) | |
| 56 | |
| 57 | |
| 58 ;;; Type coercion. | |
| 59 | |
| 60 (defun coerce (x type) | |
| 61 "Coerce OBJECT to type TYPE. | |
| 62 TYPE is a Common Lisp type specifier." | |
| 63 (cond ((eq type 'list) (if (listp x) x (append x nil))) | |
| 64 ((eq type 'vector) (if (vectorp x) x (vconcat x))) | |
| 65 ((eq type 'string) (if (stringp x) x (concat x))) | |
| 66 ((eq type 'array) (if (arrayp x) x (vconcat x))) | |
| 67 ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0)) | |
| 68 ((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type)) | |
| 2153 | 69 ;; XEmacs addition character <-> integer coercions |
| 446 | 70 ((and (eq type 'character) (char-int-p x)) (int-char x)) |
| 71 ((and (eq type 'integer) (characterp x)) (char-int x)) | |
| 428 | 72 ((eq type 'float) (float x)) |
| 2153 | 73 ;; XEmacs addition: enhanced numeric type coercions |
| 2367 | 74 ((and-fboundp 'coerce-number |
| 75 (memq type '(integer ratio bigfloat)) | |
| 76 (coerce-number x type))) | |
| 2153 | 77 ;; XEmacs addition: bit-vector coercion |
| 428 | 78 ((eq type 'bit-vector) (if (bit-vector-p x) x |
| 79 (apply 'bit-vector (append x nil)))) | |
| 2153 | 80 ;; XEmacs addition: weak-list coercion |
| 428 | 81 ((eq type 'weak-list) |
| 82 (if (weak-list-p x) x | |
| 83 (let ((wl (make-weak-list))) | |
| 84 (set-weak-list-list wl (if (listp x) x (append x nil))) | |
| 85 wl))) | |
| 86 ((typep x type) x) | |
| 87 (t (error "Can't coerce %s to type %s" x type)))) | |
| 88 | |
| 89 | |
| 90 ;;; Predicates. | |
| 91 | |
|
4792
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
92 ;; I'd actually prefer not to have this inline, the space |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
93 ;; vs. amount-it's-called trade-off isn't reasonable, but that would |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
94 ;; introduce bytecode problems with the compiler macro in cl-macs.el. |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
95 (defsubst cl-string-vector-equalp (cl-string cl-vector) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
96 "Helper function for `equalp', which see." |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
97 ; (check-argument-type #'stringp cl-string) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
98 ; (check-argument-type #'vector cl-vector) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
99 (let ((cl-i (length cl-string)) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
100 cl-char cl-other) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
101 (when (= cl-i (length cl-vector)) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
102 (while (and (>= (setq cl-i (1- cl-i)) 0) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
103 (or (eq (setq cl-char (aref cl-string cl-i)) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
104 (setq cl-other (aref cl-vector cl-i))) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
105 (and (characterp cl-other) ; Note we want to call this |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
106 ; as rarely as possible, it |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
107 ; doesn't have a bytecode. |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
108 (eq (downcase cl-char) (downcase cl-other)))))) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
109 (< cl-i 0)))) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
110 |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
111 ;; See comment on cl-string-vector-equalp above. |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
112 (defsubst cl-bit-vector-vector-equalp (cl-bit-vector cl-vector) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
113 "Helper function for `equalp', which see." |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
114 ; (check-argument-type #'bit-vector-p cl-bit-vector) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
115 ; (check-argument-type #'vectorp cl-vector) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
116 (let ((cl-i (length cl-bit-vector)) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
117 cl-other) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
118 (when (= cl-i (length cl-vector)) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
119 (while (and (>= (setq cl-i (1- cl-i)) 0) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
120 (numberp (setq cl-other (aref cl-vector cl-i))) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
121 ;; Differs from clisp here. |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
122 (= (aref cl-bit-vector cl-i) cl-other))) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
123 (< cl-i 0)))) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
124 |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
125 ;; These two helper functions call equalp recursively, the two above have no |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
126 ;; need to. |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
127 (defsubst cl-vector-array-equalp (cl-vector cl-array) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
128 "Helper function for `equalp', which see." |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
129 ; (check-argument-type #'vector cl-vector) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
130 ; (check-argument-type #'arrayp cl-array) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
131 (let ((cl-i (length cl-vector))) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
132 (when (= cl-i (length cl-array)) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
133 (while (and (>= (setq cl-i (1- cl-i)) 0) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
134 (equalp (aref cl-vector cl-i) (aref cl-array cl-i)))) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
135 (< cl-i 0)))) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
136 |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
137 (defsubst cl-hash-table-contents-equalp (cl-hash-table-1 cl-hash-table-2) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
138 "Helper function for `equalp', which see." |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
139 (symbol-macrolet |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
140 ;; If someone has gone and fished the uninterned symbol out of this |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
141 ;; function's constants vector, and subsequently stored it as a value |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
142 ;; in a hash table, it's their own damn fault when |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
143 ;; `cl-hash-table-contents-equalp' gives the wrong answer. |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
144 ((equalp-default '#:equalp-default)) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
145 (loop |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
146 for x-key being the hash-key in cl-hash-table-1 |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
147 using (hash-value x-value) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
148 with y-value = nil |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
149 always (and (not (eq equalp-default |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
150 (setq y-value (gethash x-key cl-hash-table-2 |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
151 equalp-default)))) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
152 (equalp y-value x-value))))) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
153 |
| 428 | 154 (defun equalp (x y) |
| 155 "Return t if two Lisp objects have similar structures and contents. | |
|
4792
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
156 |
| 428 | 157 This is like `equal', except that it accepts numerically equal |
|
4792
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
158 numbers of different types (float, integer, bignum, bigfloat), and also |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
159 compares strings and characters case-insensitively. |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
160 |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
161 Arrays (that is, strings, bit-vectors, and vectors) of the same length and |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
162 with contents that are `equalp' are themselves `equalp'. |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
163 |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
164 Two hash tables are `equalp' if they have the same test (see |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
165 `hash-table-test'), if they have the same number of entries, and if, for |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
166 each entry in one hash table, its key is equivalent to a key in the other |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
167 hash table using the hash table test, and its value is `equalp' to the other |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
168 hash table's value for that key." |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
169 (cond ((eq x y)) |
| 428 | 170 ((stringp x) |
|
4792
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
171 (if (stringp y) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
172 (eq t (compare-strings x nil nil y nil nil t)) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
173 (if (vectorp y) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
174 (cl-string-vector-equalp x y) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
175 ;; bit-vectors and strings are only equalp if they're |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
176 ;; zero-length: |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
177 (and (equal "" x) (equal #* y))))) |
| 428 | 178 ((numberp x) |
| 179 (and (numberp y) (= x y))) | |
| 180 ((consp x) | |
| 181 (while (and (consp x) (consp y) (equalp (car x) (car y))) | |
| 2153 | 182 (setq x (cdr x) y (cdr y))) |
| 428 | 183 (and (not (consp x)) (equalp x y))) |
|
4792
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
184 (t |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
185 ;; From here on, the type tests don't (yet) have bytecodes. |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
186 (let ((x-type (type-of x))) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
187 (cond ((eq 'vector x-type) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
188 (if (stringp y) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
189 (cl-string-vector-equalp y x) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
190 (if (vectorp y) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
191 (cl-vector-array-equalp x y) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
192 (if (bit-vector-p y) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
193 (cl-bit-vector-vector-equalp y x))))) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
194 ((eq 'character x-type) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
195 (and (characterp y) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
196 ;; If the characters are actually identical, the |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
197 ;; first eq test will have caught them above; we only |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
198 ;; need to check them case-insensitively here. |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
199 (eq (downcase x) (downcase y)))) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
200 ((eq 'hash-table x-type) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
201 (and (hash-table-p y) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
202 (eq (hash-table-test x) (hash-table-test y)) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
203 (= (hash-table-count x) (hash-table-count y)) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
204 (cl-hash-table-contents-equalp x y))) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
205 ((eq 'bit-vector x-type) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
206 (if (bit-vector-p y) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
207 (equal x y) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
208 (if (vectorp y) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
209 (cl-bit-vector-vector-equalp x y) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
210 ;; bit-vectors and strings are only equalp if they're |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
211 ;; zero-length: |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
212 (and (equal "" y) (equal #* x))))) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4728
diff
changeset
|
213 (t (equal x y))))))) |
| 428 | 214 |
| 215 ;;; Control structures. | |
| 216 | |
| 217 (defun cl-mapcar-many (cl-func cl-seqs) | |
| 218 (if (cdr (cdr cl-seqs)) | |
| 219 (let* ((cl-res nil) | |
| 220 (cl-n (apply 'min (mapcar 'length cl-seqs))) | |
| 221 (cl-i 0) | |
| 222 (cl-args (copy-sequence cl-seqs)) | |
| 223 cl-p1 cl-p2) | |
| 224 (setq cl-seqs (copy-sequence cl-seqs)) | |
| 225 (while (< cl-i cl-n) | |
| 226 (setq cl-p1 cl-seqs cl-p2 cl-args) | |
| 227 (while cl-p1 | |
| 228 (setcar cl-p2 | |
| 229 (if (consp (car cl-p1)) | |
| 230 (prog1 (car (car cl-p1)) | |
| 231 (setcar cl-p1 (cdr (car cl-p1)))) | |
| 232 (aref (car cl-p1) cl-i))) | |
| 233 (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))) | |
| 2153 | 234 (push (apply cl-func cl-args) cl-res) |
| 428 | 235 (setq cl-i (1+ cl-i))) |
| 236 (nreverse cl-res)) | |
| 237 (let ((cl-res nil) | |
| 238 (cl-x (car cl-seqs)) | |
| 239 (cl-y (nth 1 cl-seqs))) | |
| 240 (let ((cl-n (min (length cl-x) (length cl-y))) | |
| 241 (cl-i -1)) | |
| 242 (while (< (setq cl-i (1+ cl-i)) cl-n) | |
| 2153 | 243 (push (funcall cl-func |
| 244 (if (consp cl-x) (pop cl-x) (aref cl-x cl-i)) | |
| 245 (if (consp cl-y) (pop cl-y) (aref cl-y cl-i))) | |
| 428 | 246 cl-res))) |
| 247 (nreverse cl-res)))) | |
| 248 | |
| 249 (defun map (cl-type cl-func cl-seq &rest cl-rest) | |
| 250 "Map a function across one or more sequences, returning a sequence. | |
| 251 TYPE is the sequence type to return, FUNC is the function, and SEQS | |
| 252 are the argument sequences." | |
| 253 (let ((cl-res (apply 'mapcar* cl-func cl-seq cl-rest))) | |
| 254 (and cl-type (coerce cl-res cl-type)))) | |
| 255 | |
| 256 (defun maplist (cl-func cl-list &rest cl-rest) | |
| 257 "Map FUNC to each sublist of LIST or LISTS. | |
| 258 Like `mapcar', except applies to lists and their cdr's rather than to | |
| 259 the elements themselves." | |
| 260 (if cl-rest | |
| 261 (let ((cl-res nil) | |
| 262 (cl-args (cons cl-list (copy-sequence cl-rest))) | |
| 263 cl-p) | |
| 264 (while (not (memq nil cl-args)) | |
| 2153 | 265 (push (apply cl-func cl-args) cl-res) |
| 428 | 266 (setq cl-p cl-args) |
| 2153 | 267 (while cl-p (setcar cl-p (cdr (pop cl-p)) ))) |
| 428 | 268 (nreverse cl-res)) |
| 269 (let ((cl-res nil)) | |
| 270 (while cl-list | |
| 2153 | 271 (push (funcall cl-func cl-list) cl-res) |
| 428 | 272 (setq cl-list (cdr cl-list))) |
| 273 (nreverse cl-res)))) | |
| 274 | |
| 2153 | 275 ;; XEmacs change: in Emacs, this function is named cl-mapc. |
| 428 | 276 (defun mapc (cl-func cl-seq &rest cl-rest) |
| 277 "Like `mapcar', but does not accumulate values returned by the function." | |
| 278 (if cl-rest | |
| 279 (apply 'map nil cl-func cl-seq cl-rest) | |
| 280 ;; XEmacs change: in the simplest case we call mapc-internal, | |
| 281 ;; which really doesn't accumulate any results. | |
| 282 (mapc-internal cl-func cl-seq)) | |
| 283 cl-seq) | |
| 284 | |
| 2153 | 285 ;; XEmacs addition: FSF compatibility |
| 286 (defalias 'cl-mapc 'mapc) | |
| 287 | |
| 428 | 288 (defun mapl (cl-func cl-list &rest cl-rest) |
| 289 "Like `maplist', but does not accumulate values returned by the function." | |
| 290 (if cl-rest | |
| 291 (apply 'maplist cl-func cl-list cl-rest) | |
| 292 (let ((cl-p cl-list)) | |
| 293 (while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p))))) | |
| 294 cl-list) | |
| 295 | |
| 296 (defun mapcan (cl-func cl-seq &rest cl-rest) | |
| 297 "Like `mapcar', but nconc's together the values returned by the function." | |
| 298 (apply 'nconc (apply 'mapcar* cl-func cl-seq cl-rest))) | |
| 299 | |
| 300 (defun mapcon (cl-func cl-list &rest cl-rest) | |
| 301 "Like `maplist', but nconc's together the values returned by the function." | |
| 302 (apply 'nconc (apply 'maplist cl-func cl-list cl-rest))) | |
| 303 | |
| 304 (defun some (cl-pred cl-seq &rest cl-rest) | |
| 305 "Return true if PREDICATE is true of any element of SEQ or SEQs. | |
| 306 If so, return the true (non-nil) value returned by PREDICATE." | |
| 307 (if (or cl-rest (nlistp cl-seq)) | |
| 308 (catch 'cl-some | |
| 309 (apply 'map nil | |
| 310 (function (lambda (&rest cl-x) | |
| 311 (let ((cl-res (apply cl-pred cl-x))) | |
| 312 (if cl-res (throw 'cl-some cl-res))))) | |
| 313 cl-seq cl-rest) nil) | |
| 314 (let ((cl-x nil)) | |
| 2153 | 315 (while (and cl-seq (not (setq cl-x (funcall cl-pred (pop cl-seq)))))) |
| 428 | 316 cl-x))) |
| 317 | |
| 318 (defun every (cl-pred cl-seq &rest cl-rest) | |
| 319 "Return true if PREDICATE is true of every element of SEQ or SEQs." | |
| 320 (if (or cl-rest (nlistp cl-seq)) | |
| 321 (catch 'cl-every | |
| 322 (apply 'map nil | |
| 323 (function (lambda (&rest cl-x) | |
| 324 (or (apply cl-pred cl-x) (throw 'cl-every nil)))) | |
| 325 cl-seq cl-rest) t) | |
| 326 (while (and cl-seq (funcall cl-pred (car cl-seq))) | |
| 327 (setq cl-seq (cdr cl-seq))) | |
| 328 (null cl-seq))) | |
| 329 | |
| 330 (defun notany (cl-pred cl-seq &rest cl-rest) | |
| 331 "Return true if PREDICATE is false of every element of SEQ or SEQs." | |
| 332 (not (apply 'some cl-pred cl-seq cl-rest))) | |
| 333 | |
| 334 (defun notevery (cl-pred cl-seq &rest cl-rest) | |
| 335 "Return true if PREDICATE is false of some element of SEQ or SEQs." | |
| 336 (not (apply 'every cl-pred cl-seq cl-rest))) | |
| 337 | |
| 338 ;;; Support for `loop'. | |
| 2153 | 339 (defalias 'cl-map-keymap 'map-keymap) |
| 428 | 340 |
| 341 (defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base) | |
| 342 (or cl-base | |
| 2153 | 343 (setq cl-base (copy-sequence [0]))) |
| 344 (map-keymap | |
| 428 | 345 (function |
| 346 (lambda (cl-key cl-bind) | |
| 347 (aset cl-base (1- (length cl-base)) cl-key) | |
| 348 (if (keymapp cl-bind) | |
| 349 (cl-map-keymap-recursively | |
| 350 cl-func-rec cl-bind | |
| 2153 | 351 (vconcat cl-base (list 0))) |
| 428 | 352 (funcall cl-func-rec cl-base cl-bind)))) |
| 353 cl-map)) | |
| 354 | |
| 355 (defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end) | |
| 356 (or cl-what (setq cl-what (current-buffer))) | |
| 357 (if (bufferp cl-what) | |
| 358 (let (cl-mark cl-mark2 (cl-next t) cl-next2) | |
| 2153 | 359 (with-current-buffer cl-what |
| 428 | 360 (setq cl-mark (copy-marker (or cl-start (point-min)))) |
| 361 (setq cl-mark2 (and cl-end (copy-marker cl-end)))) | |
| 362 (while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2))) | |
| 2153 | 363 (setq cl-next (if cl-prop (next-single-property-change |
| 364 cl-mark cl-prop cl-what) | |
| 365 (next-property-change cl-mark cl-what)) | |
| 366 cl-next2 (or cl-next (with-current-buffer cl-what | |
| 367 (point-max)))) | |
| 428 | 368 (funcall cl-func (prog1 (marker-position cl-mark) |
| 369 (set-marker cl-mark cl-next2)) | |
| 370 (if cl-mark2 (min cl-next2 cl-mark2) cl-next2))) | |
| 371 (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil))) | |
| 372 (or cl-start (setq cl-start 0)) | |
| 373 (or cl-end (setq cl-end (length cl-what))) | |
| 374 (while (< cl-start cl-end) | |
| 2153 | 375 (let ((cl-next (or (if cl-prop (next-single-property-change |
| 376 cl-start cl-prop cl-what) | |
| 377 (next-property-change cl-start cl-what)) | |
| 428 | 378 cl-end))) |
| 379 (funcall cl-func cl-start (min cl-next cl-end)) | |
| 380 (setq cl-start cl-next))))) | |
| 381 | |
| 382 (defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg) | |
| 383 (or cl-buffer (setq cl-buffer (current-buffer))) | |
| 502 | 384 (with-fboundp '(overlay-start overlay-end overlays-at next-overlay-change) |
| 385 (if-fboundp 'overlay-lists | |
| 428 | 386 |
| 502 | 387 ;; This is the preferred algorithm, though overlay-lists is |
| 388 ;; undocumented. | |
| 389 (let (cl-ovl) | |
| 2153 | 390 (with-current-buffer cl-buffer |
| 502 | 391 (setq cl-ovl (overlay-lists)) |
| 392 (if cl-start (setq cl-start (copy-marker cl-start))) | |
| 393 (if cl-end (setq cl-end (copy-marker cl-end)))) | |
| 394 (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl))) | |
| 395 (while (and cl-ovl | |
| 396 (or (not (overlay-start (car cl-ovl))) | |
| 397 (and cl-end (>= (overlay-start (car cl-ovl)) cl-end)) | |
| 398 (and cl-start (<= (overlay-end (car cl-ovl)) | |
| 399 cl-start)) | |
| 400 (not (funcall cl-func (car cl-ovl) cl-arg)))) | |
| 401 (setq cl-ovl (cdr cl-ovl))) | |
| 402 (if cl-start (set-marker cl-start nil)) | |
| 403 (if cl-end (set-marker cl-end nil))) | |
| 404 | |
| 405 ;; This alternate algorithm fails to find zero-length overlays. | |
| 2153 | 406 (let ((cl-mark (with-current-buffer cl-buffer |
| 407 (copy-marker (or cl-start (point-min))))) | |
| 408 (cl-mark2 (and cl-end (with-current-buffer cl-buffer | |
| 409 (copy-marker cl-end)))) | |
| 502 | 410 cl-pos cl-ovl) |
| 411 (while (save-excursion | |
| 412 (and (setq cl-pos (marker-position cl-mark)) | |
| 413 (< cl-pos (or cl-mark2 (point-max))) | |
| 414 (progn | |
| 415 (set-buffer cl-buffer) | |
| 416 (setq cl-ovl (overlays-at cl-pos)) | |
| 417 (set-marker cl-mark (next-overlay-change cl-pos))))) | |
| 418 (while (and cl-ovl | |
| 419 (or (/= (overlay-start (car cl-ovl)) cl-pos) | |
| 420 (not (and (funcall cl-func (car cl-ovl) cl-arg) | |
| 421 (set-marker cl-mark nil))))) | |
| 422 (setq cl-ovl (cdr cl-ovl)))) | |
| 423 (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))))) | |
| 428 | 424 |
| 425 ;;; Support for `setf'. | |
| 426 (defun cl-set-frame-visible-p (frame val) | |
| 427 (cond ((null val) (make-frame-invisible frame)) | |
| 428 ((eq val 'icon) (iconify-frame frame)) | |
| 429 (t (make-frame-visible frame))) | |
| 430 val) | |
| 431 | |
| 432 ;;; Support for `progv'. | |
| 433 (defvar cl-progv-save) | |
| 434 (defun cl-progv-before (syms values) | |
| 435 (while syms | |
| 2153 | 436 (push (if (boundp (car syms)) |
| 428 | 437 (cons (car syms) (symbol-value (car syms))) |
| 438 (car syms)) cl-progv-save) | |
| 439 (if values | |
| 2153 | 440 (set (pop syms) (pop values)) |
| 441 (makunbound (pop syms))))) | |
| 428 | 442 |
| 443 (defun cl-progv-after () | |
| 444 (while cl-progv-save | |
| 445 (if (consp (car cl-progv-save)) | |
| 446 (set (car (car cl-progv-save)) (cdr (car cl-progv-save))) | |
| 447 (makunbound (car cl-progv-save))) | |
| 2153 | 448 (pop cl-progv-save))) |
| 428 | 449 |
| 450 | |
| 451 ;;; Numbers. | |
| 452 | |
| 453 (defun gcd (&rest args) | |
| 454 "Return the greatest common divisor of the arguments." | |
| 2153 | 455 (let ((a (abs (or (pop args) 0)))) |
| 428 | 456 (while args |
| 2153 | 457 (let ((b (abs (pop args)))) |
| 428 | 458 (while (> b 0) (setq b (% a (setq a b)))))) |
| 459 a)) | |
| 460 | |
| 461 (defun lcm (&rest args) | |
| 462 "Return the least common multiple of the arguments." | |
| 463 (if (memq 0 args) | |
| 464 0 | |
| 2153 | 465 (let ((a (abs (or (pop args) 1)))) |
| 428 | 466 (while args |
| 2153 | 467 (let ((b (abs (pop args)))) |
| 428 | 468 (setq a (* (/ a (gcd a b)) b)))) |
| 469 a))) | |
| 470 | |
| 471 (defun isqrt (a) | |
| 472 "Return the integer square root of the argument." | |
| 473 (if (and (integerp a) (> a 0)) | |
| 474 ;; XEmacs change | |
| 475 (let ((g (cond ((>= a 1000000) 10000) ((>= a 10000) 1000) | |
| 476 ((>= a 100) 100) (t 10))) | |
| 477 g2) | |
| 478 (while (< (setq g2 (/ (+ g (/ a g)) 2)) g) | |
| 479 (setq g g2)) | |
| 480 g) | |
| 481 (if (eq a 0) 0 (signal 'arith-error nil)))) | |
| 482 | |
| 2153 | 483 ;; XEmacs addition |
| 428 | 484 (defun cl-expt (x y) |
| 485 "Return X raised to the power of Y. Works only for integer arguments." | |
| 486 (if (<= y 0) (if (= y 0) 1 (if (memq x '(-1 1)) (cl-expt x (- y)) 0)) | |
| 487 (* (if (= (% y 2) 0) 1 x) (cl-expt (* x x) (/ y 2))))) | |
| 488 (or (and (fboundp 'expt) (subrp (symbol-function 'expt))) | |
| 489 (defalias 'expt 'cl-expt)) | |
| 490 | |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
491 ;; 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
|
492 ;; definition-and-call: |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
493 ((macro . (lambda (&rest symbols) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
494 "Make some old CL package truncate and round functions available. |
| 428 | 495 |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
496 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
|
497 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
|
498 (let (symbol result) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
499 (while symbols |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
500 (setq symbol (car symbols) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
501 symbols (cdr symbols)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
502 (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
|
503 ',symbol "21.5.29") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
504 result) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
505 (push |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
506 `(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
|
507 ,(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
|
508 symbol) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
509 (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
|
510 result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
511 (cons 'progn result)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
512 ceiling floor round truncate) |
| 428 | 513 |
| 514 (defun mod* (x y) | |
| 515 "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
|
516 (nth-value 1 (floor x y))) |
| 428 | 517 |
| 518 (defun rem* (x y) | |
| 519 "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
|
520 (nth-value 1 (truncate x y))) |
| 428 | 521 |
| 522 (defun signum (a) | |
| 523 "Return 1 if A is positive, -1 if negative, 0 if zero." | |
| 524 (cond ((> a 0) 1) ((< a 0) -1) (t 0))) | |
| 525 | |
| 526 ;; Random numbers. | |
| 527 | |
| 528 (defvar *random-state*) | |
| 529 (defun random* (lim &optional state) | |
| 530 "Return a random nonnegative number less than LIM, an integer or float. | |
| 531 Optional second arg STATE is a random-state object." | |
| 532 (or state (setq state *random-state*)) | |
| 533 ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method. | |
| 534 (let ((vec (aref state 3))) | |
| 535 (if (integerp vec) | |
| 536 (let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1)) | |
| 537 (aset state 3 (setq vec (make-vector 55 nil))) | |
| 538 (aset vec 0 j) | |
| 539 (while (> (setq i (% (+ i 21) 55)) 0) | |
| 540 (aset vec i (setq j (prog1 k (setq k (- j k)))))) | |
| 541 (while (< (setq i (1+ i)) 200) (random* 2 state)))) | |
| 542 (let* ((i (aset state 1 (% (1+ (aref state 1)) 55))) | |
| 543 (j (aset state 2 (% (1+ (aref state 2)) 55))) | |
| 544 (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j)))))) | |
| 545 (if (integerp lim) | |
| 546 (if (<= lim 512) (% n lim) | |
| 547 (if (> lim 8388607) (setq n (+ (lsh n 9) (random* 512 state)))) | |
| 548 (let ((mask 1023)) | |
| 549 (while (< mask (1- lim)) (setq mask (1+ (+ mask mask)))) | |
| 550 (if (< (setq n (logand n mask)) lim) n (random* lim state)))) | |
| 551 (* (/ n '8388608e0) lim))))) | |
| 552 | |
| 553 (defun make-random-state (&optional state) | |
| 554 "Return a copy of random-state STATE, or of `*random-state*' if omitted. | |
| 555 If STATE is t, return a new state object seeded from the time of day." | |
| 556 (cond ((null state) (make-random-state *random-state*)) | |
| 557 ((vectorp state) (cl-copy-tree state t)) | |
| 558 ((integerp state) (vector 'cl-random-state-tag -1 30 state)) | |
| 559 (t (make-random-state (cl-random-time))))) | |
| 560 | |
| 561 (defun random-state-p (object) | |
| 562 "Return t if OBJECT is a random-state object." | |
| 563 (and (vectorp object) (= (length object) 4) | |
| 564 (eq (aref object 0) 'cl-random-state-tag))) | |
| 565 | |
| 566 | |
| 567 ;; Implementation limits. | |
| 568 | |
| 569 (defun cl-finite-do (func a b) | |
| 570 (condition-case nil | |
| 571 (let ((res (funcall func a b))) ; check for IEEE infinity | |
| 572 (and (numberp res) (/= res (/ res 2)) res)) | |
| 573 (arith-error nil))) | |
| 574 | |
| 575 (defvar most-positive-float) | |
| 576 (defvar most-negative-float) | |
| 577 (defvar least-positive-float) | |
| 578 (defvar least-negative-float) | |
| 579 (defvar least-positive-normalized-float) | |
| 580 (defvar least-negative-normalized-float) | |
| 581 (defvar float-epsilon) | |
| 582 (defvar float-negative-epsilon) | |
| 583 | |
| 584 (defun cl-float-limits () | |
| 585 (or most-positive-float (not (numberp '2e1)) | |
| 586 (let ((x '2e0) y z) | |
| 587 ;; Find maximum exponent (first two loops are optimizations) | |
| 588 (while (cl-finite-do '* x x) (setq x (* x x))) | |
| 589 (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2)))) | |
| 590 (while (cl-finite-do '+ x x) (setq x (+ x x))) | |
| 591 (setq z x y (/ x 2)) | |
| 592 ;; Now fill in 1's in the mantissa. | |
| 593 (while (and (cl-finite-do '+ x y) (/= (+ x y) x)) | |
| 594 (setq x (+ x y) y (/ y 2))) | |
| 595 (setq most-positive-float x | |
| 596 most-negative-float (- x)) | |
| 597 ;; Divide down until mantissa starts rounding. | |
| 598 (setq x (/ x z) y (/ 16 z) x (* x y)) | |
| 599 (while (condition-case nil (and (= x (* (/ x 2) 2)) (> (/ y 2) 0)) | |
| 600 (arith-error nil)) | |
| 601 (setq x (/ x 2) y (/ y 2))) | |
| 602 (setq least-positive-normalized-float y | |
| 603 least-negative-normalized-float (- y)) | |
| 604 ;; Divide down until value underflows to zero. | |
| 605 (setq x (/ 1 z) y x) | |
| 606 (while (condition-case nil (> (/ x 2) 0) (arith-error nil)) | |
| 607 (setq x (/ x 2))) | |
| 608 (setq least-positive-float x | |
| 609 least-negative-float (- x)) | |
| 610 (setq x '1e0) | |
| 611 (while (/= (+ '1e0 x) '1e0) (setq x (/ x 2))) | |
| 612 (setq float-epsilon (* x 2)) | |
| 613 (setq x '1e0) | |
| 614 (while (/= (- '1e0 x) '1e0) (setq x (/ x 2))) | |
| 615 (setq float-negative-epsilon (* x 2)))) | |
| 616 nil) | |
| 617 | |
| 618 | |
| 619 ;;; Sequence functions. | |
| 620 | |
| 621 ;XEmacs -- our built-in is more powerful. | |
| 622 ;(defun subseq (seq start &optional end) | |
| 623 ; "Return the subsequence of SEQ from START to END. | |
| 624 ;If END is omitted, it defaults to the length of the sequence. | |
| 625 ;If START or END is negative, it counts from the end." | |
| 626 ; (if (stringp seq) (substring seq start end) | |
| 627 ; (let (len) | |
| 628 ; (and end (< end 0) (setq end (+ end (setq len (length seq))))) | |
| 629 ; (if (< start 0) (setq start (+ start (or len (setq len (length seq)))))) | |
| 630 ; (cond ((listp seq) | |
| 631 ; (if (> start 0) (setq seq (nthcdr start seq))) | |
| 632 ; (if end | |
| 633 ; (let ((res nil)) | |
| 634 ; (while (>= (setq end (1- end)) start) | |
| 2153 | 635 ; (push (pop seq) res)) |
| 428 | 636 ; (nreverse res)) |
| 637 ; (copy-sequence seq))) | |
| 638 ; (t | |
| 639 ; (or end (setq end (or len (length seq)))) | |
| 640 ; (let ((res (make-vector (max (- end start) 0) nil)) | |
| 641 ; (i 0)) | |
| 642 ; (while (< start end) | |
| 643 ; (aset res i (aref seq start)) | |
| 644 ; (setq i (1+ i) start (1+ start))) | |
| 645 ; res)))))) | |
| 646 | |
| 647 (defun concatenate (type &rest seqs) | |
| 648 "Concatenate, into a sequence of type TYPE, the argument SEQUENCES." | |
| 2153 | 649 ;; XEmacs change: use case instead of cond for clarity |
| 428 | 650 (case type |
| 651 (vector (apply 'vconcat seqs)) | |
| 652 (string (apply 'concat seqs)) | |
| 653 (list (apply 'append (append seqs '(nil)))) | |
| 654 (t (error "Not a sequence type name: %s" type)))) | |
| 655 | |
| 656 ;;; List functions. | |
| 657 | |
| 658 (defun revappend (x y) | |
| 659 "Equivalent to (append (reverse X) Y)." | |
| 660 (nconc (reverse x) y)) | |
| 661 | |
| 662 (defun nreconc (x y) | |
| 663 "Equivalent to (nconc (nreverse X) Y)." | |
| 664 (nconc (nreverse x) y)) | |
| 665 | |
| 666 (defun list-length (x) | |
| 667 "Return the length of a list. Return nil if list is circular." | |
| 668 (let ((n 0) (fast x) (slow x)) | |
| 669 (while (and (cdr fast) (not (and (eq fast slow) (> n 0)))) | |
| 670 (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow))) | |
| 671 (if fast (if (cdr fast) nil (1+ n)) n))) | |
| 672 | |
| 673 (defun tailp (sublist list) | |
| 674 "Return true if SUBLIST is a tail of LIST." | |
| 675 (while (and (consp list) (not (eq sublist list))) | |
| 676 (setq list (cdr list))) | |
| 677 (if (numberp sublist) (equal sublist list) (eq sublist list))) | |
| 678 | |
| 2153 | 679 (defalias 'cl-copy-tree 'copy-tree) |
| 428 | 680 |
| 681 | |
| 682 ;;; Property lists. | |
| 683 | |
| 684 ;; XEmacs: our `get' groks DEFAULT. | |
| 685 (defalias 'get* 'get) | |
| 442 | 686 (defalias 'getf 'plist-get) |
| 428 | 687 |
| 688 (defun cl-set-getf (plist tag val) | |
| 689 (let ((p plist)) | |
| 690 (while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p)))) | |
| 691 (if p (progn (setcar (cdr p) val) plist) (list* tag val plist)))) | |
| 692 | |
| 693 (defun cl-do-remf (plist tag) | |
| 694 (let ((p (cdr plist))) | |
| 695 (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) | |
| 696 (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) | |
| 697 | |
| 2153 | 698 ;; XEmacs change: we have a builtin remprop |
| 699 (defalias 'cl-remprop 'remprop) | |
| 700 | |
| 701 | |
| 702 | |
| 428 | 703 ;;; Hash tables. |
| 704 | |
| 705 ;; The `regular' Common Lisp hash-table stuff has been moved into C. | |
| 706 ;; Only backward compatibility stuff remains here. | |
| 707 (defun make-hashtable (size &optional test) | |
| 708 (make-hash-table :test test :size size)) | |
| 709 (defun make-weak-hashtable (size &optional test) | |
| 710 (make-hash-table :test test :size size :weakness t)) | |
| 711 (defun make-key-weak-hashtable (size &optional test) | |
| 712 (make-hash-table :test test :size size :weakness 'key)) | |
| 713 (defun make-value-weak-hashtable (size &optional test) | |
| 714 (make-hash-table :test test :size size :weakness 'value)) | |
| 715 | |
| 716 (define-obsolete-function-alias 'hashtablep 'hash-table-p) | |
| 717 (define-obsolete-function-alias 'hashtable-fullness 'hash-table-count) | |
| 718 (define-obsolete-function-alias 'hashtable-test-function 'hash-table-test) | |
| 719 (define-obsolete-function-alias 'hashtable-type 'hash-table-type) | |
| 720 (define-obsolete-function-alias 'hashtable-size 'hash-table-size) | |
| 721 (define-obsolete-function-alias 'copy-hashtable 'copy-hash-table) | |
| 722 | |
| 723 (make-obsolete 'make-hashtable 'make-hash-table) | |
| 724 (make-obsolete 'make-weak-hashtable 'make-hash-table) | |
| 725 (make-obsolete 'make-key-weak-hashtable 'make-hash-table) | |
| 726 (make-obsolete 'make-value-weak-hashtable 'make-hash-table) | |
| 727 (make-obsolete 'hash-table-type 'hash-table-weakness) | |
| 728 | |
| 729 (when (fboundp 'x-keysym-hash-table) | |
| 730 (make-obsolete 'x-keysym-hashtable 'x-keysym-hash-table)) | |
| 731 | |
| 732 ;; Compatibility stuff for old kludgy cl.el hash table implementation | |
| 733 (defvar cl-builtin-gethash (symbol-function 'gethash)) | |
| 734 (defvar cl-builtin-remhash (symbol-function 'remhash)) | |
| 735 (defvar cl-builtin-clrhash (symbol-function 'clrhash)) | |
| 736 (defvar cl-builtin-maphash (symbol-function 'maphash)) | |
| 737 | |
| 738 (defalias 'cl-gethash 'gethash) | |
| 739 (defalias 'cl-puthash 'puthash) | |
| 740 (defalias 'cl-remhash 'remhash) | |
| 741 (defalias 'cl-clrhash 'clrhash) | |
| 742 (defalias 'cl-maphash 'maphash) | |
| 2153 | 743 ;; These three actually didn't exist in Emacs-20. |
| 744 (defalias 'cl-make-hash-table 'make-hash-table) | |
| 745 (defalias 'cl-hash-table-p 'hash-table-p) | |
| 746 (defalias 'cl-hash-table-count 'hash-table-count) | |
| 428 | 747 |
| 748 ;;; Some debugging aids. | |
| 749 | |
| 750 (defun cl-prettyprint (form) | |
| 751 "Insert a pretty-printed rendition of a Lisp FORM in current buffer." | |
| 752 (let ((pt (point)) last) | |
| 753 (insert "\n" (prin1-to-string form) "\n") | |
| 754 (setq last (point)) | |
| 755 (goto-char (1+ pt)) | |
| 756 (while (search-forward "(quote " last t) | |
| 757 (delete-backward-char 7) | |
| 758 (insert "'") | |
| 759 (forward-sexp) | |
| 760 (delete-char 1)) | |
| 761 (goto-char (1+ pt)) | |
| 762 (cl-do-prettyprint))) | |
| 763 | |
| 764 (defun cl-do-prettyprint () | |
| 765 (skip-chars-forward " ") | |
| 766 (if (looking-at "(") | |
| 1729 | 767 (let ((skip (or (looking-at "((") |
| 2153 | 768 ;; XEmacs: be selective about trailing stuff after prog |
| 1729 | 769 (looking-at "(prog[nv12\\(ress-feedback\\|n-with-message\\)]") |
| 428 | 770 (looking-at "(unwind-protect ") |
| 771 (looking-at "(function (") | |
| 772 (looking-at "(cl-block-wrapper "))) | |
| 773 (two (or (looking-at "(defun ") (looking-at "(defmacro "))) | |
| 774 (let (or (looking-at "(let\\*? ") (looking-at "(while "))) | |
| 775 (set (looking-at "(p?set[qf] "))) | |
| 776 (if (or skip let | |
| 777 (progn | |
| 778 (forward-sexp) | |
| 779 (and (>= (current-column) 78) (progn (backward-sexp) t)))) | |
| 780 (let ((nl t)) | |
| 781 (forward-char 1) | |
| 782 (cl-do-prettyprint) | |
| 783 (or skip (looking-at ")") (cl-do-prettyprint)) | |
| 784 (or (not two) (looking-at ")") (cl-do-prettyprint)) | |
| 785 (while (not (looking-at ")")) | |
| 786 (if set (setq nl (not nl))) | |
| 787 (if nl (insert "\n")) | |
| 788 (lisp-indent-line) | |
| 789 (cl-do-prettyprint)) | |
| 790 (forward-char 1)))) | |
| 791 (forward-sexp))) | |
| 792 | |
| 793 (defvar cl-macroexpand-cmacs nil) | |
| 794 (defvar cl-closure-vars nil) | |
| 795 | |
| 796 (defun cl-macroexpand-all (form &optional env) | |
| 797 "Expand all macro calls through a Lisp FORM. | |
| 798 This also does some trivial optimizations to make the form prettier." | |
| 799 (while (or (not (eq form (setq form (macroexpand form env)))) | |
| 800 (and cl-macroexpand-cmacs | |
| 801 (not (eq form (setq form (compiler-macroexpand form))))))) | |
| 802 (cond ((not (consp form)) form) | |
| 803 ((memq (car form) '(let let*)) | |
| 804 (if (null (nth 1 form)) | |
| 805 (cl-macroexpand-all (cons 'progn (cddr form)) env) | |
| 806 (let ((letf nil) (res nil) (lets (cadr form))) | |
| 807 (while lets | |
| 2153 | 808 (push (if (consp (car lets)) |
| 428 | 809 (let ((exp (cl-macroexpand-all (caar lets) env))) |
| 810 (or (symbolp exp) (setq letf t)) | |
| 811 (cons exp (cl-macroexpand-body (cdar lets) env))) | |
| 812 (let ((exp (cl-macroexpand-all (car lets) env))) | |
| 813 (if (symbolp exp) exp | |
| 814 (setq letf t) (list exp nil)))) res) | |
| 815 (setq lets (cdr lets))) | |
| 816 (list* (if letf (if (eq (car form) 'let) 'letf 'letf*) (car form)) | |
| 817 (nreverse res) (cl-macroexpand-body (cddr form) env))))) | |
| 818 ((eq (car form) 'cond) | |
| 819 (cons (car form) | |
| 820 (mapcar (function (lambda (x) (cl-macroexpand-body x env))) | |
| 821 (cdr form)))) | |
| 822 ((eq (car form) 'condition-case) | |
| 823 (list* (car form) (nth 1 form) (cl-macroexpand-all (nth 2 form) env) | |
| 824 (mapcar (function | |
| 825 (lambda (x) | |
| 826 (cons (car x) (cl-macroexpand-body (cdr x) env)))) | |
| 827 (cdddr form)))) | |
| 828 ((memq (car form) '(quote function)) | |
| 829 (if (eq (car-safe (nth 1 form)) 'lambda) | |
| 830 (let ((body (cl-macroexpand-body (cddadr form) env))) | |
| 831 (if (and cl-closure-vars (eq (car form) 'function) | |
| 832 (cl-expr-contains-any body cl-closure-vars)) | |
| 833 (let* ((new (mapcar 'gensym cl-closure-vars)) | |
| 834 (sub (pairlis cl-closure-vars new)) (decls nil)) | |
| 835 (while (or (stringp (car body)) | |
| 836 (eq (car-safe (car body)) 'interactive)) | |
| 2153 | 837 (push (list 'quote (pop body)) decls)) |
| 428 | 838 (put (car (last cl-closure-vars)) 'used t) |
| 839 (append | |
| 840 (list 'list '(quote lambda) '(quote (&rest --cl-rest--))) | |
| 841 (sublis sub (nreverse decls)) | |
| 842 (list | |
| 843 (list* 'list '(quote apply) | |
| 2153 | 844 ;; XEmacs: put a quote before the function |
| 428 | 845 (list 'list '(quote quote) |
| 846 (list 'function | |
| 847 (list* 'lambda | |
| 848 (append new (cadadr form)) | |
| 849 (sublis sub body)))) | |
| 850 (nconc (mapcar (function | |
| 851 (lambda (x) | |
| 852 (list 'list '(quote quote) x))) | |
| 853 cl-closure-vars) | |
| 854 '((quote --cl-rest--))))))) | |
| 855 (list (car form) (list* 'lambda (cadadr form) body)))) | |
| 856 (let ((found (assq (cadr form) env))) | |
| 2153 | 857 ;; XEmacs: cadr/caddr operate on nil without errors |
| 428 | 858 (if (eq (cadr (caddr found)) 'cl-labels-args) |
| 859 (cl-macroexpand-all (cadr (caddr (cadddr found))) env) | |
| 860 form)))) | |
| 861 ((memq (car form) '(defun defmacro)) | |
| 862 (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env))) | |
| 863 ((and (eq (car form) 'progn) (not (cddr form))) | |
| 864 (cl-macroexpand-all (nth 1 form) env)) | |
| 865 ((eq (car form) 'setq) | |
| 866 (let* ((args (cl-macroexpand-body (cdr form) env)) (p args)) | |
| 867 (while (and p (symbolp (car p))) (setq p (cddr p))) | |
| 868 (if p (cl-macroexpand-all (cons 'setf args)) (cons 'setq args)))) | |
| 869 (t (cons (car form) (cl-macroexpand-body (cdr form) env))))) | |
| 870 | |
| 871 (defun cl-macroexpand-body (body &optional env) | |
| 872 (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body)) | |
| 873 | |
| 874 (defun cl-prettyexpand (form &optional full) | |
| 875 (message "Expanding...") | |
| 876 (let ((cl-macroexpand-cmacs full) (cl-compiling-file full) | |
| 877 (byte-compile-macro-environment nil)) | |
| 878 (setq form (cl-macroexpand-all form | |
| 879 (and (not full) '((block) (eval-when))))) | |
| 880 (message "Formatting...") | |
| 881 (prog1 (cl-prettyprint form) | |
| 882 (message "")))) | |
| 883 | |
| 884 | |
| 885 | |
| 886 (run-hooks 'cl-extra-load-hook) | |
| 887 | |
| 2153 | 888 ;; XEmacs addition |
| 428 | 889 (provide 'cl-extra) |
| 890 | |
| 2153 | 891 ;;; arch-tag: bcd03437-0871-43fb-a8f1-ad0e0b5427ed |
| 428 | 892 ;;; cl-extra.el ends here |