Mercurial > emacs
comparison lisp/emacs-lisp/cl-extra.el @ 88155:d7ddb3e565de
sync with trunk
author | Henrik Enberg <henrik.enberg@telia.com> |
---|---|
date | Mon, 16 Jan 2006 00:03:54 +0000 |
parents | a6d932b28650 |
children |
comparison
equal
deleted
inserted
replaced
88154:8ce476d3ba36 | 88155:d7ddb3e565de |
---|---|
1 ;;; cl-extra.el --- Common Lisp features, part 2 -*-byte-compile-dynamic: t;-*- | 1 ;;; cl-extra.el --- Common Lisp features, part 2 -*-byte-compile-dynamic: t;-*- |
2 | 2 |
3 ;; Copyright (C) 1993,2000 Free Software Foundation, Inc. | 3 ;; Copyright (C) 1993, 2000, 2002, 2003, 2004, |
4 ;; 2005 Free Software Foundation, Inc. | |
4 | 5 |
5 ;; Author: Dave Gillespie <daveg@synaptics.com> | 6 ;; Author: Dave Gillespie <daveg@synaptics.com> |
6 ;; Keywords: extensions | 7 ;; Keywords: extensions |
7 | 8 |
8 ;; This file is part of GNU Emacs. | 9 ;; This file is part of GNU Emacs. |
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
18 ;; GNU General Public License for more details. | 19 ;; GNU General Public License for more details. |
19 | 20 |
20 ;; You should have received a copy of the GNU General Public License | 21 ;; You should have received a copy of the GNU General Public License |
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the | 22 ;; along with GNU Emacs; see the file COPYING. If not, write to the |
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | 23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
23 ;; Boston, MA 02111-1307, USA. | 24 ;; Boston, MA 02110-1301, USA. |
24 | 25 |
25 ;;; Commentary: | 26 ;;; Commentary: |
26 | 27 |
27 ;; These are extensions to Emacs Lisp that provide a degree of | 28 ;; These are extensions to Emacs Lisp that provide a degree of |
28 ;; Common Lisp compatibility, beyond what is already built-in | 29 ;; Common Lisp compatibility, beyond what is already built-in |
36 ;; This file contains portions of the Common Lisp extensions | 37 ;; This file contains portions of the Common Lisp extensions |
37 ;; package which are autoloaded since they are relatively obscure. | 38 ;; package which are autoloaded since they are relatively obscure. |
38 | 39 |
39 ;;; Code: | 40 ;;; Code: |
40 | 41 |
41 (or (memq 'cl-19 features) | 42 (require 'cl) |
42 (error "Tried to load `cl-extra' before `cl'!")) | |
43 | |
44 | 43 |
45 ;;; Type coercion. | 44 ;;; Type coercion. |
46 | 45 |
47 (defun coerce (x type) | 46 (defun coerce (x type) |
48 "Coerce OBJECT to type TYPE. | 47 "Coerce OBJECT to type TYPE. |
49 TYPE is a Common Lisp type specifier." | 48 TYPE is a Common Lisp type specifier. |
49 \n(fn OBJECT TYPE)" | |
50 (cond ((eq type 'list) (if (listp x) x (append x nil))) | 50 (cond ((eq type 'list) (if (listp x) x (append x nil))) |
51 ((eq type 'vector) (if (vectorp x) x (vconcat x))) | 51 ((eq type 'vector) (if (vectorp x) x (vconcat x))) |
52 ((eq type 'string) (if (stringp x) x (concat x))) | 52 ((eq type 'string) (if (stringp x) x (concat x))) |
53 ((eq type 'array) (if (arrayp x) x (vconcat x))) | 53 ((eq type 'array) (if (arrayp x) x (vconcat x))) |
54 ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0)) | 54 ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0)) |
59 | 59 |
60 | 60 |
61 ;;; Predicates. | 61 ;;; Predicates. |
62 | 62 |
63 (defun equalp (x y) | 63 (defun equalp (x y) |
64 "T if two Lisp objects have similar structures and contents. | 64 "Return t if two Lisp objects have similar structures and contents. |
65 This is like `equal', except that it accepts numerically equal | 65 This is like `equal', except that it accepts numerically equal |
66 numbers of different types (float vs. integer), and also compares | 66 numbers of different types (float vs. integer), and also compares |
67 strings case-insensitively." | 67 strings case-insensitively." |
68 (cond ((eq x y) t) | 68 (cond ((eq x y) t) |
69 ((stringp x) | 69 ((stringp x) |
118 (if (consp cl-y) (pop cl-y) (aref cl-y cl-i))) | 118 (if (consp cl-y) (pop cl-y) (aref cl-y cl-i))) |
119 cl-res))) | 119 cl-res))) |
120 (nreverse cl-res)))) | 120 (nreverse cl-res)))) |
121 | 121 |
122 (defun map (cl-type cl-func cl-seq &rest cl-rest) | 122 (defun map (cl-type cl-func cl-seq &rest cl-rest) |
123 "Map a function across one or more sequences, returning a sequence. | 123 "Map a FUNCTION across one or more SEQUENCEs, returning a sequence. |
124 TYPE is the sequence type to return, FUNC is the function, and SEQS | 124 TYPE is the sequence type to return. |
125 are the argument sequences." | 125 \n(fn TYPE FUNCTION SEQUENCE...)" |
126 (let ((cl-res (apply 'mapcar* cl-func cl-seq cl-rest))) | 126 (let ((cl-res (apply 'mapcar* cl-func cl-seq cl-rest))) |
127 (and cl-type (coerce cl-res cl-type)))) | 127 (and cl-type (coerce cl-res cl-type)))) |
128 | 128 |
129 (defun maplist (cl-func cl-list &rest cl-rest) | 129 (defun maplist (cl-func cl-list &rest cl-rest) |
130 "Map FUNC to each sublist of LIST or LISTS. | 130 "Map FUNCTION to each sublist of LIST or LISTs. |
131 Like `mapcar', except applies to lists and their cdr's rather than to | 131 Like `mapcar', except applies to lists and their cdr's rather than to |
132 the elements themselves." | 132 the elements themselves. |
133 \n(fn FUNCTION LIST...)" | |
133 (if cl-rest | 134 (if cl-rest |
134 (let ((cl-res nil) | 135 (let ((cl-res nil) |
135 (cl-args (cons cl-list (copy-sequence cl-rest))) | 136 (cl-args (cons cl-list (copy-sequence cl-rest))) |
136 cl-p) | 137 cl-p) |
137 (while (not (memq nil cl-args)) | 138 (while (not (memq nil cl-args)) |
144 (push (funcall cl-func cl-list) cl-res) | 145 (push (funcall cl-func cl-list) cl-res) |
145 (setq cl-list (cdr cl-list))) | 146 (setq cl-list (cdr cl-list))) |
146 (nreverse cl-res)))) | 147 (nreverse cl-res)))) |
147 | 148 |
148 (defun cl-mapc (cl-func cl-seq &rest cl-rest) | 149 (defun cl-mapc (cl-func cl-seq &rest cl-rest) |
149 "Like `mapcar', but does not accumulate values returned by the function." | 150 "Like `mapcar', but does not accumulate values returned by the function. |
151 \n(fn FUNCTION SEQUENCE...)" | |
150 (if cl-rest | 152 (if cl-rest |
151 (progn (apply 'map nil cl-func cl-seq cl-rest) | 153 (progn (apply 'map nil cl-func cl-seq cl-rest) |
152 cl-seq) | 154 cl-seq) |
153 (mapc cl-func cl-seq))) | 155 (mapc cl-func cl-seq))) |
154 | 156 |
155 (defun mapl (cl-func cl-list &rest cl-rest) | 157 (defun mapl (cl-func cl-list &rest cl-rest) |
156 "Like `maplist', but does not accumulate values returned by the function." | 158 "Like `maplist', but does not accumulate values returned by the function. |
159 \n(fn FUNCTION LIST...)" | |
157 (if cl-rest | 160 (if cl-rest |
158 (apply 'maplist cl-func cl-list cl-rest) | 161 (apply 'maplist cl-func cl-list cl-rest) |
159 (let ((cl-p cl-list)) | 162 (let ((cl-p cl-list)) |
160 (while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p))))) | 163 (while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p))))) |
161 cl-list) | 164 cl-list) |
162 | 165 |
163 (defun mapcan (cl-func cl-seq &rest cl-rest) | 166 (defun mapcan (cl-func cl-seq &rest cl-rest) |
164 "Like `mapcar', but nconc's together the values returned by the function." | 167 "Like `mapcar', but nconc's together the values returned by the function. |
168 \n(fn FUNCTION SEQUENCE...)" | |
165 (apply 'nconc (apply 'mapcar* cl-func cl-seq cl-rest))) | 169 (apply 'nconc (apply 'mapcar* cl-func cl-seq cl-rest))) |
166 | 170 |
167 (defun mapcon (cl-func cl-list &rest cl-rest) | 171 (defun mapcon (cl-func cl-list &rest cl-rest) |
168 "Like `maplist', but nconc's together the values returned by the function." | 172 "Like `maplist', but nconc's together the values returned by the function. |
173 \n(fn FUNCTION LIST...)" | |
169 (apply 'nconc (apply 'maplist cl-func cl-list cl-rest))) | 174 (apply 'nconc (apply 'maplist cl-func cl-list cl-rest))) |
170 | 175 |
171 (defun some (cl-pred cl-seq &rest cl-rest) | 176 (defun some (cl-pred cl-seq &rest cl-rest) |
172 "Return true if PREDICATE is true of any element of SEQ or SEQs. | 177 "Return true if PREDICATE is true of any element of SEQ or SEQs. |
173 If so, return the true (non-nil) value returned by PREDICATE." | 178 If so, return the true (non-nil) value returned by PREDICATE. |
179 \n(fn PREDICATE SEQ...)" | |
174 (if (or cl-rest (nlistp cl-seq)) | 180 (if (or cl-rest (nlistp cl-seq)) |
175 (catch 'cl-some | 181 (catch 'cl-some |
176 (apply 'map nil | 182 (apply 'map nil |
177 (function (lambda (&rest cl-x) | 183 (function (lambda (&rest cl-x) |
178 (let ((cl-res (apply cl-pred cl-x))) | 184 (let ((cl-res (apply cl-pred cl-x))) |
181 (let ((cl-x nil)) | 187 (let ((cl-x nil)) |
182 (while (and cl-seq (not (setq cl-x (funcall cl-pred (pop cl-seq)))))) | 188 (while (and cl-seq (not (setq cl-x (funcall cl-pred (pop cl-seq)))))) |
183 cl-x))) | 189 cl-x))) |
184 | 190 |
185 (defun every (cl-pred cl-seq &rest cl-rest) | 191 (defun every (cl-pred cl-seq &rest cl-rest) |
186 "Return true if PREDICATE is true of every element of SEQ or SEQs." | 192 "Return true if PREDICATE is true of every element of SEQ or SEQs. |
193 \n(fn PREDICATE SEQ...)" | |
187 (if (or cl-rest (nlistp cl-seq)) | 194 (if (or cl-rest (nlistp cl-seq)) |
188 (catch 'cl-every | 195 (catch 'cl-every |
189 (apply 'map nil | 196 (apply 'map nil |
190 (function (lambda (&rest cl-x) | 197 (function (lambda (&rest cl-x) |
191 (or (apply cl-pred cl-x) (throw 'cl-every nil)))) | 198 (or (apply cl-pred cl-x) (throw 'cl-every nil)))) |
193 (while (and cl-seq (funcall cl-pred (car cl-seq))) | 200 (while (and cl-seq (funcall cl-pred (car cl-seq))) |
194 (setq cl-seq (cdr cl-seq))) | 201 (setq cl-seq (cdr cl-seq))) |
195 (null cl-seq))) | 202 (null cl-seq))) |
196 | 203 |
197 (defun notany (cl-pred cl-seq &rest cl-rest) | 204 (defun notany (cl-pred cl-seq &rest cl-rest) |
198 "Return true if PREDICATE is false of every element of SEQ or SEQs." | 205 "Return true if PREDICATE is false of every element of SEQ or SEQs. |
206 \n(fn PREDICATE SEQ...)" | |
199 (not (apply 'some cl-pred cl-seq cl-rest))) | 207 (not (apply 'some cl-pred cl-seq cl-rest))) |
200 | 208 |
201 (defun notevery (cl-pred cl-seq &rest cl-rest) | 209 (defun notevery (cl-pred cl-seq &rest cl-rest) |
202 "Return true if PREDICATE is false of some element of SEQ or SEQs." | 210 "Return true if PREDICATE is false of some element of SEQ or SEQs. |
211 \n(fn PREDICATE SEQ...)" | |
203 (not (apply 'every cl-pred cl-seq cl-rest))) | 212 (not (apply 'every cl-pred cl-seq cl-rest))) |
204 | 213 |
205 ;;; Support for `loop'. | 214 ;;; Support for `loop'. |
206 (defun cl-map-keymap (cl-func cl-map) | 215 (defalias 'cl-map-keymap 'map-keymap) |
207 (while (symbolp cl-map) (setq cl-map (symbol-function cl-map))) | |
208 (if (listp cl-map) | |
209 (let ((cl-p cl-map)) | |
210 (while (consp (setq cl-p (cdr cl-p))) | |
211 (cond ((consp (car cl-p)) | |
212 (funcall cl-func (car (car cl-p)) (cdr (car cl-p)))) | |
213 ((or (vectorp (car cl-p)) (char-table-p (car cl-p))) | |
214 (cl-map-keymap cl-func (car cl-p))) | |
215 ((eq (car cl-p) 'keymap) | |
216 (setq cl-p nil))))) | |
217 (let ((cl-i -1)) | |
218 (while (< (setq cl-i (1+ cl-i)) (length cl-map)) | |
219 (if (aref cl-map cl-i) | |
220 (funcall cl-func cl-i (aref cl-map cl-i))))))) | |
221 | 216 |
222 (defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base) | 217 (defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base) |
223 (or cl-base | 218 (or cl-base |
224 (setq cl-base (copy-sequence [0]))) | 219 (setq cl-base (copy-sequence [0]))) |
225 (cl-map-keymap | 220 (map-keymap |
226 (function | 221 (function |
227 (lambda (cl-key cl-bind) | 222 (lambda (cl-key cl-bind) |
228 (aset cl-base (1- (length cl-base)) cl-key) | 223 (aset cl-base (1- (length cl-base)) cl-key) |
229 (if (keymapp cl-bind) | 224 (if (keymapp cl-bind) |
230 (cl-map-keymap-recursively | 225 (cl-map-keymap-recursively |
344 (while args | 339 (while args |
345 (let ((b (abs (pop args)))) | 340 (let ((b (abs (pop args)))) |
346 (setq a (* (/ a (gcd a b)) b)))) | 341 (setq a (* (/ a (gcd a b)) b)))) |
347 a))) | 342 a))) |
348 | 343 |
349 (defun isqrt (a) | 344 (defun isqrt (x) |
350 "Return the integer square root of the argument." | 345 "Return the integer square root of the argument." |
351 (if (and (integerp a) (> a 0)) | 346 (if (and (integerp x) (> x 0)) |
352 (let ((g (cond ((<= a 100) 10) ((<= a 10000) 100) | 347 (let ((g (cond ((<= x 100) 10) ((<= x 10000) 100) |
353 ((<= a 1000000) 1000) (t a))) | 348 ((<= x 1000000) 1000) (t x))) |
354 g2) | 349 g2) |
355 (while (< (setq g2 (/ (+ g (/ a g)) 2)) g) | 350 (while (< (setq g2 (/ (+ g (/ x g)) 2)) g) |
356 (setq g g2)) | 351 (setq g g2)) |
357 g) | 352 g) |
358 (if (eq a 0) 0 (signal 'arith-error nil)))) | 353 (if (eq x 0) 0 (signal 'arith-error nil)))) |
359 | 354 |
360 (defun floor* (x &optional y) | 355 (defun floor* (x &optional y) |
361 "Return a list of the floor of X and the fractional part of X. | 356 "Return a list of the floor of X and the fractional part of X. |
362 With two arguments, return floor and remainder of their quotient." | 357 With two arguments, return floor and remainder of their quotient." |
363 (let ((q (floor x y))) | 358 (let ((q (floor x y))) |
400 | 395 |
401 (defun rem* (x y) | 396 (defun rem* (x y) |
402 "The remainder of X divided by Y, with the same sign as X." | 397 "The remainder of X divided by Y, with the same sign as X." |
403 (nth 1 (truncate* x y))) | 398 (nth 1 (truncate* x y))) |
404 | 399 |
405 (defun signum (a) | 400 (defun signum (x) |
406 "Return 1 if A is positive, -1 if negative, 0 if zero." | 401 "Return 1 if X is positive, -1 if negative, 0 if zero." |
407 (cond ((> a 0) 1) ((< a 0) -1) (t 0))) | 402 (cond ((> x 0) 1) ((< x 0) -1) (t 0))) |
408 | 403 |
409 | 404 |
410 ;; Random numbers. | 405 ;; Random numbers. |
411 | 406 |
412 (defvar *random-state*) | 407 (defvar *random-state*) |
526 (aset res i (aref seq start)) | 521 (aset res i (aref seq start)) |
527 (setq i (1+ i) start (1+ start))) | 522 (setq i (1+ i) start (1+ start))) |
528 res)))))) | 523 res)))))) |
529 | 524 |
530 (defun concatenate (type &rest seqs) | 525 (defun concatenate (type &rest seqs) |
531 "Concatenate, into a sequence of type TYPE, the argument SEQUENCES." | 526 "Concatenate, into a sequence of type TYPE, the argument SEQUENCEs. |
527 \n(fn TYPE SEQUENCE...)" | |
532 (cond ((eq type 'vector) (apply 'vconcat seqs)) | 528 (cond ((eq type 'vector) (apply 'vconcat seqs)) |
533 ((eq type 'string) (apply 'concat seqs)) | 529 ((eq type 'string) (apply 'concat seqs)) |
534 ((eq type 'list) (apply 'append (append seqs '(nil)))) | 530 ((eq type 'list) (apply 'append (append seqs '(nil)))) |
535 (t (error "Not a sequence type name: %s" type)))) | 531 (t (error "Not a sequence type name: %s" type)))) |
536 | 532 |
544 (defun nreconc (x y) | 540 (defun nreconc (x y) |
545 "Equivalent to (nconc (nreverse X) Y)." | 541 "Equivalent to (nconc (nreverse X) Y)." |
546 (nconc (nreverse x) y)) | 542 (nconc (nreverse x) y)) |
547 | 543 |
548 (defun list-length (x) | 544 (defun list-length (x) |
549 "Return the length of a list. Return nil if list is circular." | 545 "Return the length of list X. Return nil if list is circular." |
550 (let ((n 0) (fast x) (slow x)) | 546 (let ((n 0) (fast x) (slow x)) |
551 (while (and (cdr fast) (not (and (eq fast slow) (> n 0)))) | 547 (while (and (cdr fast) (not (and (eq fast slow) (> n 0)))) |
552 (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow))) | 548 (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow))) |
553 (if fast (if (cdr fast) nil (1+ n)) n))) | 549 (if fast (if (cdr fast) nil (1+ n)) n))) |
554 | 550 |
562 | 558 |
563 | 559 |
564 ;;; Property lists. | 560 ;;; Property lists. |
565 | 561 |
566 (defun get* (sym tag &optional def) ; See compiler macro in cl-macs.el | 562 (defun get* (sym tag &optional def) ; See compiler macro in cl-macs.el |
567 "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none." | 563 "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none. |
564 \n(fn SYMBOL PROPNAME &optional DEFAULT)" | |
568 (or (get sym tag) | 565 (or (get sym tag) |
569 (and def | 566 (and def |
570 (let ((plist (symbol-plist sym))) | 567 (let ((plist (symbol-plist sym))) |
571 (while (and plist (not (eq (car plist) tag))) | 568 (while (and plist (not (eq (car plist) tag))) |
572 (setq plist (cdr (cdr plist)))) | 569 (setq plist (cdr (cdr plist)))) |
573 (if plist (car (cdr plist)) def))))) | 570 (if plist (car (cdr plist)) def))))) |
574 | 571 |
575 (defun getf (plist tag &optional def) | 572 (defun getf (plist tag &optional def) |
576 "Search PROPLIST for property PROPNAME; return its value or DEFAULT. | 573 "Search PROPLIST for property PROPNAME; return its value or DEFAULT. |
577 PROPLIST is a list of the sort returned by `symbol-plist'." | 574 PROPLIST is a list of the sort returned by `symbol-plist'. |
575 \n(fn PROPLIST PROPNAME &optional DEFAULT)" | |
578 (setplist '--cl-getf-symbol-- plist) | 576 (setplist '--cl-getf-symbol-- plist) |
579 (or (get '--cl-getf-symbol-- tag) | 577 (or (get '--cl-getf-symbol-- tag) |
580 ;; Originally we called get* here, | 578 ;; Originally we called get* here, |
581 ;; but that fails, because get* has a compiler macro | 579 ;; but that fails, because get* has a compiler macro |
582 ;; definition that uses getf! | 580 ;; definition that uses getf! |
594 (let ((p (cdr plist))) | 592 (let ((p (cdr plist))) |
595 (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) | 593 (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) |
596 (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) | 594 (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) |
597 | 595 |
598 (defun cl-remprop (sym tag) | 596 (defun cl-remprop (sym tag) |
599 "Remove from SYMBOL's plist the property PROP and its value." | 597 "Remove from SYMBOL's plist the property PROPNAME and its value. |
598 \n(fn SYMBOL PROPNAME)" | |
600 (let ((plist (symbol-plist sym))) | 599 (let ((plist (symbol-plist sym))) |
601 (if (and plist (eq tag (car plist))) | 600 (if (and plist (eq tag (car plist))) |
602 (progn (setplist sym (cdr (cdr plist))) t) | 601 (progn (setplist sym (cdr (cdr plist))) t) |
603 (cl-do-remf plist tag)))) | 602 (cl-do-remf plist tag)))) |
604 (defalias 'remprop 'cl-remprop) | 603 (defalias 'remprop 'cl-remprop) |
719 (append | 718 (append |
720 (list 'list '(quote lambda) '(quote (&rest --cl-rest--))) | 719 (list 'list '(quote lambda) '(quote (&rest --cl-rest--))) |
721 (sublis sub (nreverse decls)) | 720 (sublis sub (nreverse decls)) |
722 (list | 721 (list |
723 (list* 'list '(quote apply) | 722 (list* 'list '(quote apply) |
724 (list 'list '(quote quote) | 723 (list 'function |
725 (list 'function | 724 (list* 'lambda |
726 (list* 'lambda | 725 (append new (cadadr form)) |
727 (append new (cadadr form)) | 726 (sublis sub body))) |
728 (sublis sub body)))) | |
729 (nconc (mapcar (function | 727 (nconc (mapcar (function |
730 (lambda (x) | 728 (lambda (x) |
731 (list 'list '(quote quote) x))) | 729 (list 'list '(quote quote) x))) |
732 cl-closure-vars) | 730 cl-closure-vars) |
733 '((quote --cl-rest--))))))) | 731 '((quote --cl-rest--))))))) |
734 (list (car form) (list* 'lambda (cadadr form) body)))) | 732 (list (car form) (list* 'lambda (cadadr form) body)))) |
735 (let ((found (assq (cadr form) env))) | 733 (let ((found (assq (cadr form) env))) |
736 (if (eq (cadr (caddr found)) 'cl-labels-args) | 734 (if (and found (ignore-errors |
735 (eq (cadr (caddr found)) 'cl-labels-args))) | |
737 (cl-macroexpand-all (cadr (caddr (cadddr found))) env) | 736 (cl-macroexpand-all (cadr (caddr (cadddr found))) env) |
738 form)))) | 737 form)))) |
739 ((memq (car form) '(defun defmacro)) | 738 ((memq (car form) '(defun defmacro)) |
740 (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env))) | 739 (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env))) |
741 ((and (eq (car form) 'progn) (not (cddr form))) | 740 ((and (eq (car form) 'progn) (not (cddr form))) |
742 (cl-macroexpand-all (nth 1 form) env)) | 741 (cl-macroexpand-all (nth 1 form) env)) |
743 ((eq (car form) 'setq) | 742 ((eq (car form) 'setq) |
744 (let* ((args (cl-macroexpand-body (cdr form) env)) (p args)) | 743 (let* ((args (cl-macroexpand-body (cdr form) env)) (p args)) |
745 (while (and p (symbolp (car p))) (setq p (cddr p))) | 744 (while (and p (symbolp (car p))) (setq p (cddr p))) |
746 (if p (cl-macroexpand-all (cons 'setf args)) (cons 'setq args)))) | 745 (if p (cl-macroexpand-all (cons 'setf args)) (cons 'setq args)))) |
746 ((consp (car form)) | |
747 (cl-macroexpand-all (list* 'funcall | |
748 (list 'function (car form)) | |
749 (cdr form)) | |
750 env)) | |
747 (t (cons (car form) (cl-macroexpand-body (cdr form) env))))) | 751 (t (cons (car form) (cl-macroexpand-body (cdr form) env))))) |
748 | 752 |
749 (defun cl-macroexpand-body (body &optional env) | 753 (defun cl-macroexpand-body (body &optional env) |
750 (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body)) | 754 (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body)) |
751 | 755 |
761 | 765 |
762 | 766 |
763 | 767 |
764 (run-hooks 'cl-extra-load-hook) | 768 (run-hooks 'cl-extra-load-hook) |
765 | 769 |
770 ;; arch-tag: bcd03437-0871-43fb-a8f1-ad0e0b5427ed | |
766 ;;; cl-extra.el ends here | 771 ;;; cl-extra.el ends here |