Commit | Line | Data |
---|---|---|
7c1898a7 | 1 | ;;; cl.el --- Compatibility aliases for the old CL library. |
fcd73769 | 2 | |
7c1898a7 | 3 | ;; Copyright (C) 2012 Free Software Foundation, Inc. |
fcd73769 | 4 | |
7c1898a7 | 5 | ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> |
fcd73769 RS |
6 | ;; Keywords: extensions |
7 | ||
8 | ;; This file is part of GNU Emacs. | |
9 | ||
d6cba7ae | 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
fcd73769 | 11 | ;; it under the terms of the GNU General Public License as published by |
d6cba7ae GM |
12 | ;; the Free Software Foundation, either version 3 of the License, or |
13 | ;; (at your option) any later version. | |
fcd73769 RS |
14 | |
15 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;; GNU General Public License for more details. | |
19 | ||
20 | ;; You should have received a copy of the GNU General Public License | |
d6cba7ae | 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
fcd73769 | 22 | |
07b3798c | 23 | ;;; Commentary: |
fcd73769 | 24 | |
7c1898a7 SM |
25 | ;; This is a compatibility file which provides the old names provided by CL |
26 | ;; before we cleaned up its namespace usage. | |
fcd73769 | 27 | |
07b3798c | 28 | ;;; Code: |
fcd73769 | 29 | |
7c1898a7 | 30 | (require 'cl-lib) |
de7e2b36 | 31 | (require 'macroexp) |
7c1898a7 SM |
32 | |
33 | ;; (defun cl--rename () | |
34 | ;; (let ((vdefs ()) | |
35 | ;; (fdefs ()) | |
36 | ;; (case-fold-search nil) | |
37 | ;; (files '("cl.el" "cl-macs.el" "cl-seq.el" "cl-extra.el"))) | |
38 | ;; (dolist (file files) | |
39 | ;; (with-current-buffer (find-file-noselect file) | |
40 | ;; (goto-char (point-min)) | |
41 | ;; (while (re-search-forward | |
42 | ;; "^(\\(def[^ \t\n]*\\) +'?\\(\\(\\sw\\|\\s_\\)+\\)" nil t) | |
43 | ;; (let ((name (match-string-no-properties 2)) | |
44 | ;; (type (match-string-no-properties 1))) | |
45 | ;; (unless (string-match-p "\\`cl-" name) | |
46 | ;; (cond | |
47 | ;; ((member type '("defvar" "defconst")) | |
48 | ;; (unless (member name vdefs) (push name vdefs))) | |
49 | ;; ((member type '("defun" "defsubst" "defalias" "defmacro")) | |
50 | ;; (unless (member name fdefs) (push name fdefs))) | |
51 | ;; ((member type '("def-edebug-spec" "defsetf" "define-setf-method" | |
52 | ;; "define-compiler-macro")) | |
53 | ;; nil) | |
54 | ;; (t (error "Unknown type %S" type)))))))) | |
55 | ;; (let ((re (concat "\\_<" (regexp-opt (append vdefs fdefs)) "\\_>")) | |
56 | ;; (conflicts ())) | |
57 | ;; (dolist (file files) | |
58 | ;; (with-current-buffer (find-file-noselect file) | |
59 | ;; (goto-char (point-min)) | |
60 | ;; (while (re-search-forward re nil t) | |
61 | ;; (replace-match "cl-\\&")) | |
62 | ;; (save-buffer)))) | |
63 | ;; (with-current-buffer (find-file-noselect "cl-rename.el") | |
64 | ;; (dolist (def vdefs) | |
65 | ;; (insert (format "(defvaralias '%s 'cl-%s)\n" def def))) | |
66 | ;; (dolist (def fdefs) | |
67 | ;; (insert (format "(defalias '%s 'cl-%s)\n" def def))) | |
68 | ;; (save-buffer)))) | |
69 | ||
70 | ;; (defun cl--unrename () | |
71 | ;; ;; Taken from "Naming Conventions" node of the doc. | |
72 | ;; (let* ((names '(defun* defsubst* defmacro* function* member* | |
73 | ;; assoc* rassoc* get* remove* delete* | |
74 | ;; mapcar* sort* floor* ceiling* truncate* | |
75 | ;; round* mod* rem* random*)) | |
76 | ;; (files '("cl.el" "cl-lib.el" "cl-macs.el" "cl-seq.el" "cl-extra.el")) | |
77 | ;; (re (concat "\\_<cl-" (regexp-opt (mapcar #'symbol-name names)) | |
78 | ;; "\\_>"))) | |
79 | ;; (dolist (file files) | |
80 | ;; (with-current-buffer (find-file-noselect file) | |
81 | ;; (goto-char (point-min)) | |
82 | ;; (while (re-search-forward re nil t) | |
83 | ;; (delete-region (1- (point)) (point))) | |
84 | ;; (save-buffer))))) | |
2ee3d7f0 SM |
85 | |
86 | ;;; Aliases to cl-lib's features. | |
87 | ||
7c1898a7 SM |
88 | (dolist (var '( |
89 | ;; loop-result-var | |
90 | ;; loop-result | |
91 | ;; loop-initially | |
92 | ;; loop-finally | |
93 | ;; loop-bindings | |
94 | ;; loop-args | |
95 | ;; bind-inits | |
96 | ;; bind-block | |
97 | ;; lambda-list-keywords | |
98 | float-negative-epsilon | |
99 | float-epsilon | |
100 | least-negative-normalized-float | |
101 | least-positive-normalized-float | |
102 | least-negative-float | |
103 | least-positive-float | |
104 | most-negative-float | |
105 | most-positive-float | |
106 | ;; custom-print-functions | |
107 | )) | |
108 | (defvaralias var (intern (format "cl-%s" var)))) | |
109 | ||
36cec983 SM |
110 | ;; Before overwriting subr.el's `dotimes' and `dolist', let's remember |
111 | ;; them under a different name, so we can use them in our implementation | |
112 | ;; of `dotimes' and `dolist'. | |
113 | (unless (fboundp 'cl--dotimes) | |
114 | (defalias 'cl--dotimes (symbol-function 'dotimes) "The non-CL `dotimes'.")) | |
115 | (unless (fboundp 'cl--dolist) | |
116 | (defalias 'cl--dolist (symbol-function 'dolist) "The non-CL `dolist'.")) | |
117 | ||
7c1898a7 SM |
118 | (dolist (fun '( |
119 | (get* . cl-get) | |
120 | (random* . cl-random) | |
121 | (rem* . cl-rem) | |
122 | (mod* . cl-mod) | |
123 | (round* . cl-round) | |
124 | (truncate* . cl-truncate) | |
125 | (ceiling* . cl-ceiling) | |
126 | (floor* . cl-floor) | |
127 | (rassoc* . cl-rassoc) | |
128 | (assoc* . cl-assoc) | |
129 | (member* . cl-member) | |
130 | (delete* . cl-delete) | |
131 | (remove* . cl-remove) | |
132 | (defsubst* . cl-defsubst) | |
133 | (sort* . cl-sort) | |
134 | (function* . cl-function) | |
135 | (defmacro* . cl-defmacro) | |
136 | (defun* . cl-defun) | |
137 | (mapcar* . cl-mapcar) | |
138 | ||
139 | remprop | |
140 | getf | |
141 | tailp | |
142 | list-length | |
143 | nreconc | |
144 | revappend | |
145 | concatenate | |
146 | subseq | |
147 | random-state-p | |
148 | make-random-state | |
149 | signum | |
150 | isqrt | |
151 | lcm | |
152 | gcd | |
153 | notevery | |
154 | notany | |
155 | every | |
156 | some | |
157 | mapcon | |
158 | mapcan | |
159 | mapl | |
160 | maplist | |
161 | map | |
162 | equalp | |
163 | coerce | |
164 | tree-equal | |
165 | nsublis | |
166 | sublis | |
167 | nsubst-if-not | |
168 | nsubst-if | |
169 | nsubst | |
170 | subst-if-not | |
171 | subst-if | |
172 | subsetp | |
173 | nset-exclusive-or | |
174 | set-exclusive-or | |
175 | nset-difference | |
176 | set-difference | |
177 | nintersection | |
178 | intersection | |
179 | nunion | |
180 | union | |
181 | rassoc-if-not | |
182 | rassoc-if | |
183 | assoc-if-not | |
184 | assoc-if | |
185 | member-if-not | |
186 | member-if | |
187 | merge | |
188 | stable-sort | |
189 | search | |
190 | mismatch | |
191 | count-if-not | |
192 | count-if | |
193 | count | |
194 | position-if-not | |
195 | position-if | |
196 | position | |
197 | find-if-not | |
198 | find-if | |
199 | find | |
200 | nsubstitute-if-not | |
201 | nsubstitute-if | |
202 | nsubstitute | |
203 | substitute-if-not | |
204 | substitute-if | |
205 | substitute | |
206 | delete-duplicates | |
207 | remove-duplicates | |
208 | delete-if-not | |
209 | delete-if | |
210 | remove-if-not | |
211 | remove-if | |
212 | replace | |
213 | fill | |
214 | reduce | |
215 | compiler-macroexpand | |
216 | define-compiler-macro | |
217 | assert | |
218 | check-type | |
219 | typep | |
220 | deftype | |
221 | defstruct | |
7c1898a7 SM |
222 | callf2 |
223 | callf | |
224 | letf* | |
225 | letf | |
226 | rotatef | |
227 | shiftf | |
228 | remf | |
229 | psetf | |
2ee3d7f0 | 230 | (define-setf-method . define-setf-expander) |
7c1898a7 SM |
231 | declare |
232 | the | |
233 | locally | |
234 | multiple-value-setq | |
235 | multiple-value-bind | |
7c1898a7 SM |
236 | symbol-macrolet |
237 | macrolet | |
7c1898a7 SM |
238 | flet |
239 | progv | |
240 | psetq | |
241 | do-all-symbols | |
242 | do-symbols | |
243 | dotimes | |
244 | dolist | |
245 | do* | |
246 | do | |
247 | loop | |
248 | return-from | |
249 | return | |
250 | block | |
251 | etypecase | |
252 | typecase | |
253 | ecase | |
254 | case | |
255 | load-time-value | |
256 | eval-when | |
257 | destructuring-bind | |
258 | gentemp | |
259 | gensym | |
260 | pairlis | |
261 | acons | |
262 | subst | |
263 | adjoin | |
264 | copy-list | |
265 | ldiff | |
266 | list* | |
267 | cddddr | |
268 | cdddar | |
269 | cddadr | |
270 | cddaar | |
271 | cdaddr | |
272 | cdadar | |
273 | cdaadr | |
274 | cdaaar | |
275 | cadddr | |
276 | caddar | |
277 | cadadr | |
278 | cadaar | |
279 | caaddr | |
280 | caadar | |
281 | caaadr | |
282 | caaaar | |
283 | cdddr | |
284 | cddar | |
285 | cdadr | |
286 | cdaar | |
287 | caddr | |
288 | cadar | |
289 | caadr | |
290 | caaar | |
291 | tenth | |
292 | ninth | |
293 | eighth | |
294 | seventh | |
295 | sixth | |
296 | fifth | |
297 | fourth | |
298 | third | |
299 | endp | |
300 | rest | |
301 | second | |
302 | first | |
303 | svref | |
304 | copy-seq | |
305 | evenp | |
306 | oddp | |
307 | minusp | |
308 | plusp | |
309 | floatp-safe | |
310 | declaim | |
311 | proclaim | |
312 | nth-value | |
313 | multiple-value-call | |
314 | multiple-value-apply | |
315 | multiple-value-list | |
316 | values-list | |
317 | values | |
318 | pushnew | |
7c1898a7 SM |
319 | decf |
320 | incf | |
321 | )) | |
322 | (let ((new (if (consp fun) (prog1 (cdr fun) (setq fun (car fun))) | |
323 | (intern (format "cl-%s" fun))))) | |
324 | (defalias fun new) | |
325 | ;; If `cl-foo' is declare inline, then make `foo' inline as well, and | |
57a7d507 | 326 | ;; similarly. Same for edebug specifications, indent rules and |
7c1898a7 SM |
327 | ;; doc-string position. |
328 | ;; FIXME: For most of them, we should instead follow aliases | |
329 | ;; where applicable. | |
57a7d507 | 330 | (dolist (prop '(byte-optimizer doc-string-elt edebug-form-spec |
7c1898a7 SM |
331 | lisp-indent-function)) |
332 | (if (get new prop) | |
333 | (put fun prop (get new prop)))))) | |
416a2c45 | 334 | |
2ee3d7f0 SM |
335 | ;;; Features provided a bit differently in Elisp. |
336 | ||
337 | ;; First, the old lexical-let is now better served by `lexical-binding', tho | |
338 | ;; it's not 100% compatible. | |
339 | ||
de7e2b36 SM |
340 | (defvar cl-closure-vars nil) |
341 | (defvar cl--function-convert-cache nil) | |
342 | ||
343 | (defun cl--function-convert (f) | |
344 | "Special macro-expander for special cases of (function F). | |
345 | The two cases that are handled are: | |
346 | - closure-conversion of lambda expressions for `lexical-let'. | |
347 | - renaming of F when it's a function defined via `cl-labels' or `labels'." | |
348 | (require 'cl-macs) | |
bb3faf5b | 349 | (declare-function cl--expr-contains-any "cl-macs" (x y)) |
de7e2b36 SM |
350 | (cond |
351 | ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked | |
352 | ;; *after* handling `function', but we want to stop macroexpansion from | |
353 | ;; being applied infinitely, so we use a cache to return the exact `form' | |
354 | ;; being expanded even though we don't receive it. | |
355 | ((eq f (car cl--function-convert-cache)) (cdr cl--function-convert-cache)) | |
356 | ((eq (car-safe f) 'lambda) | |
357 | (let ((body (mapcar (lambda (f) | |
358 | (macroexpand-all f macroexpand-all-environment)) | |
359 | (cddr f)))) | |
360 | (if (and cl-closure-vars | |
361 | (cl--expr-contains-any body cl-closure-vars)) | |
362 | (let* ((new (mapcar 'cl-gensym cl-closure-vars)) | |
363 | (sub (cl-pairlis cl-closure-vars new)) (decls nil)) | |
364 | (while (or (stringp (car body)) | |
365 | (eq (car-safe (car body)) 'interactive)) | |
366 | (push (list 'quote (pop body)) decls)) | |
367 | (put (car (last cl-closure-vars)) 'used t) | |
368 | `(list 'lambda '(&rest --cl-rest--) | |
369 | ,@(cl-sublis sub (nreverse decls)) | |
370 | (list 'apply | |
371 | (list 'quote | |
372 | #'(lambda ,(append new (cadr f)) | |
373 | ,@(cl-sublis sub body))) | |
374 | ,@(nconc (mapcar (lambda (x) `(list 'quote ,x)) | |
375 | cl-closure-vars) | |
376 | '((quote --cl-rest--)))))) | |
377 | (let* ((newf `(lambda ,(cadr f) ,@body)) | |
378 | (res `(function ,newf))) | |
379 | (setq cl--function-convert-cache (cons newf res)) | |
380 | res)))) | |
381 | (t | |
382 | (let ((found (assq f macroexpand-all-environment))) | |
383 | (if (and found (ignore-errors | |
384 | (eq (cadr (cl-caddr found)) 'cl-labels-args))) | |
385 | (cadr (cl-caddr (cl-cadddr found))) | |
386 | (let ((res `(function ,f))) | |
387 | (setq cl--function-convert-cache (cons f res)) | |
388 | res)))))) | |
389 | ||
390 | (defmacro lexical-let (bindings &rest body) | |
391 | "Like `let', but lexically scoped. | |
392 | The main visible difference is that lambdas inside BODY will create | |
393 | lexical closures as in Common Lisp. | |
394 | \n(fn BINDINGS BODY)" | |
395 | (declare (indent 1) (debug let)) | |
396 | (let* ((cl-closure-vars cl-closure-vars) | |
397 | (vars (mapcar (function | |
398 | (lambda (x) | |
399 | (or (consp x) (setq x (list x))) | |
400 | (push (make-symbol (format "--cl-%s--" (car x))) | |
401 | cl-closure-vars) | |
402 | (set (car cl-closure-vars) [bad-lexical-ref]) | |
403 | (list (car x) (cadr x) (car cl-closure-vars)))) | |
404 | bindings)) | |
405 | (ebody | |
406 | (macroexpand-all | |
407 | `(cl-symbol-macrolet | |
408 | ,(mapcar (lambda (x) | |
409 | `(,(car x) (symbol-value ,(cl-caddr x)))) | |
410 | vars) | |
411 | ,@body) | |
412 | (cons (cons 'function #'cl--function-convert) | |
413 | macroexpand-all-environment)))) | |
414 | (if (not (get (car (last cl-closure-vars)) 'used)) | |
415 | ;; Turn (let ((foo (cl-gensym))) | |
416 | ;; (set foo <val>) ...(symbol-value foo)...) | |
417 | ;; into (let ((foo <val>)) ...(symbol-value 'foo)...). | |
418 | ;; This is good because it's more efficient but it only works with | |
419 | ;; dynamic scoping, since with lexical scoping we'd need | |
420 | ;; (let ((foo <val>)) ...foo...). | |
421 | `(progn | |
422 | ,@(mapcar (lambda (x) `(defvar ,(cl-caddr x))) vars) | |
423 | (let ,(mapcar (lambda (x) (list (cl-caddr x) (cadr x))) vars) | |
424 | ,(cl-sublis (mapcar (lambda (x) | |
425 | (cons (cl-caddr x) | |
426 | `',(cl-caddr x))) | |
427 | vars) | |
428 | ebody))) | |
429 | `(let ,(mapcar (lambda (x) | |
430 | (list (cl-caddr x) | |
431 | `(make-symbol ,(format "--%s--" (car x))))) | |
432 | vars) | |
2ee3d7f0 | 433 | (setf ,@(apply #'append |
de7e2b36 SM |
434 | (mapcar (lambda (x) |
435 | (list `(symbol-value ,(cl-caddr x)) (cadr x))) | |
436 | vars))) | |
437 | ,ebody)))) | |
438 | ||
439 | (defmacro lexical-let* (bindings &rest body) | |
440 | "Like `let*', but lexically scoped. | |
441 | The main visible difference is that lambdas inside BODY, and in | |
442 | successive bindings within BINDINGS, will create lexical closures | |
443 | as in Common Lisp. This is similar to the behavior of `let*' in | |
444 | Common Lisp. | |
445 | \n(fn BINDINGS BODY)" | |
446 | (declare (indent 1) (debug let)) | |
447 | (if (null bindings) (cons 'progn body) | |
448 | (setq bindings (reverse bindings)) | |
449 | (while bindings | |
450 | (setq body (list `(lexical-let (,(pop bindings)) ,@body)))) | |
451 | (car body))) | |
452 | ||
453 | ;; This should really have some way to shadow 'byte-compile properties, etc. | |
de7e2b36 SM |
454 | (defmacro flet (bindings &rest body) |
455 | "Make temporary function definitions. | |
456 | This is an analogue of `let' that operates on the function cell of FUNC | |
457 | rather than its value cell. The FORMs are evaluated with the specified | |
458 | function definitions in place, then the definitions are undone (the FUNCs | |
459 | go back to their previous definitions, or lack thereof). | |
460 | ||
461 | \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" | |
462 | (declare (indent 1) (debug cl-flet)) | |
2ee3d7f0 | 463 | `(letf* ,(mapcar |
de7e2b36 SM |
464 | (lambda (x) |
465 | (if (or (and (fboundp (car x)) | |
466 | (eq (car-safe (symbol-function (car x))) 'macro)) | |
467 | (cdr (assq (car x) macroexpand-all-environment))) | |
468 | (error "Use `labels', not `flet', to rebind macro names")) | |
469 | (let ((func `(cl-function | |
470 | (lambda ,(cadr x) | |
471 | (cl-block ,(car x) ,@(cddr x)))))) | |
bb3faf5b | 472 | (when (cl--compiling-file) |
de7e2b36 SM |
473 | ;; Bug#411. It would be nice to fix this. |
474 | (and (get (car x) 'byte-compile) | |
475 | (error "Byte-compiling a redefinition of `%s' \ | |
476 | will not work - use `labels' instead" (symbol-name (car x)))) | |
477 | ;; FIXME This affects the rest of the file, when it | |
478 | ;; should be restricted to the flet body. | |
479 | (and (boundp 'byte-compile-function-environment) | |
480 | (push (cons (car x) (eval func)) | |
481 | byte-compile-function-environment))) | |
482 | (list `(symbol-function ',(car x)) func))) | |
483 | bindings) | |
484 | ,@body)) | |
485 | ||
486 | (defmacro labels (bindings &rest body) | |
487 | "Make temporary function bindings. | |
488 | This is like `flet', except the bindings are lexical instead of dynamic. | |
489 | Unlike `flet', this macro is fully compliant with the Common Lisp standard. | |
490 | ||
491 | \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" | |
492 | (declare (indent 1) (debug cl-flet)) | |
493 | (let ((vars nil) (sets nil) (newenv macroexpand-all-environment)) | |
494 | (dolist (binding bindings) | |
495 | ;; It's important that (not (eq (symbol-name var1) (symbol-name var2))) | |
496 | ;; because these var's *names* get added to the macro-environment. | |
497 | (let ((var (make-symbol (format "--cl-%s--" (car binding))))) | |
498 | (push var vars) | |
499 | (push `(cl-function (lambda . ,(cdr binding))) sets) | |
500 | (push var sets) | |
501 | (push (cons (car binding) | |
502 | `(lambda (&rest cl-labels-args) | |
503 | (cl-list* 'funcall ',var | |
504 | cl-labels-args))) | |
505 | newenv))) | |
506 | (macroexpand-all `(lexical-let ,vars (setq ,@sets) ,@body) newenv))) | |
507 | ||
2ee3d7f0 SM |
508 | ;; Generalized variables are provided by gv.el, but some details are |
509 | ;; not 100% compatible: not worth the trouble to add them to cl-lib.el, but we | |
510 | ;; still to support old users of cl.el. | |
511 | ||
36cec983 SM |
512 | ;; FIXME: `letf' is unsatisfactory because it does not really "restore" the |
513 | ;; previous state. If the getter/setter loses information, that info is | |
514 | ;; not recovered. | |
515 | ||
2ee3d7f0 SM |
516 | (defun cl--letf (bindings simplebinds binds body) |
517 | ;; It's not quite clear what the semantics of let! should be. | |
518 | ;; E.g. in (let! ((PLACE1 VAL1) (PLACE2 VAL2)) BODY), while it's clear | |
519 | ;; that the actual assignments ("bindings") should only happen after | |
520 | ;; evaluating VAL1 and VAL2, it's not clear when the sub-expressions of | |
521 | ;; PLACE1 and PLACE2 should be evaluated. Should we have | |
522 | ;; PLACE1; VAL1; PLACE2; VAL2; bind1; bind2 | |
523 | ;; or | |
524 | ;; VAL1; VAL2; PLACE1; PLACE2; bind1; bind2 | |
525 | ;; or | |
526 | ;; VAL1; VAL2; PLACE1; bind1; PLACE2; bind2 | |
527 | ;; Common-Lisp's `psetf' does the first, so we'll do the same. | |
528 | (if (null bindings) | |
529 | (if (and (null binds) (null simplebinds)) (macroexp-progn body) | |
530 | `(let* (,@(mapcar (lambda (x) | |
531 | (pcase-let ((`(,vold ,getter ,_setter ,_vnew) x)) | |
532 | (list vold getter))) | |
533 | binds) | |
534 | ,@simplebinds) | |
535 | (unwind-protect | |
536 | ,(macroexp-progn (append | |
537 | (mapcar (lambda (x) (pcase x | |
538 | (`(,_vold ,_getter ,setter ,vnew) | |
539 | (funcall setter vnew)))) | |
540 | binds) | |
541 | body)) | |
542 | ,@(mapcar (lambda (x) (pcase-let ((`(,vold ,_getter ,setter ,_vnew) x)) | |
543 | (funcall setter vold))) | |
544 | binds)))) | |
545 | (let ((binding (car bindings))) | |
546 | (gv-letplace (getter setter) (car binding) | |
547 | (macroexp-let2 nil vnew (cadr binding) | |
548 | (if (symbolp (car binding)) | |
549 | ;; Special-case for simple variables. | |
550 | (cl--letf (cdr bindings) | |
551 | (cons `(,getter ,(if (cdr binding) vnew getter)) | |
552 | simplebinds) | |
553 | binds body) | |
554 | (cl--letf (cdr bindings) simplebinds | |
555 | (cons `(,(make-symbol "old") ,getter ,setter | |
556 | ,@(if (cdr binding) (list vnew))) | |
557 | binds) | |
558 | body))))))) | |
559 | ||
560 | (defmacro letf (bindings &rest body) | |
561 | "Temporarily bind to PLACEs. | |
562 | This is the analogue of `let', but with generalized variables (in the | |
563 | sense of `setf') for the PLACEs. Each PLACE is set to the corresponding | |
564 | VALUE, then the BODY forms are executed. On exit, either normally or | |
565 | because of a `throw' or error, the PLACEs are set back to their original | |
566 | values. Note that this macro is *not* available in Common Lisp. | |
567 | As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', | |
568 | the PLACE is not modified before executing BODY. | |
569 | ||
570 | \(fn ((PLACE VALUE) ...) BODY...)" | |
571 | (declare (indent 1) (debug ((&rest (gate gv-place &optional form)) body))) | |
572 | (cl--letf bindings () () body)) | |
573 | ||
574 | (defun cl--letf* (bindings body) | |
575 | (if (null bindings) | |
576 | (macroexp-progn body) | |
577 | (let ((binding (car bindings))) | |
578 | (if (symbolp (car binding)) | |
579 | ;; Special-case for simple variables. | |
580 | (macroexp-let* (list (if (cdr binding) binding | |
581 | (list (car binding) (car binding)))) | |
582 | (cl--letf* (cdr bindings) body)) | |
583 | (gv-letplace (getter setter) (car binding) | |
584 | (macroexp-let2 macroexp-copyable-p vnew (cadr binding) | |
585 | (macroexp-let2 nil vold getter | |
586 | `(unwind-protect | |
587 | (progn | |
588 | ,(if (cdr binding) (funcall setter vnew)) | |
589 | ,(cl--letf* (cdr bindings) body)) | |
590 | ,(funcall setter vold))))))))) | |
591 | ||
592 | (defmacro letf* (bindings &rest body) | |
593 | (declare (indent 1) (debug letf)) | |
594 | (cl--letf* bindings body)) | |
595 | ||
36cec983 SM |
596 | (defun cl--gv-adapt (cl-gv do) |
597 | ;; This function is used by all .elc files that use define-setf-expander and | |
598 | ;; were compiled with Emacs>=24.2. | |
2ee3d7f0 SM |
599 | (let ((vars (nth 0 cl-gv)) |
600 | (vals (nth 1 cl-gv)) | |
601 | (binds ()) | |
602 | (substs ())) | |
603 | ;; Use cl-sublis as was done in cl-setf-do-modify. | |
604 | (while vars | |
605 | (if (macroexp-copyable-p (car vals)) | |
606 | (push (cons (pop vars) (pop vals)) substs) | |
607 | (push (list (pop vars) (pop vals)) binds))) | |
608 | (macroexp-let* | |
609 | binds | |
610 | (funcall do (cl-sublis substs (nth 4 cl-gv)) | |
611 | ;; We'd like to do something like | |
612 | ;; (lambda ,(nth 2 cl-gv) ,(nth 3 cl-gv)). | |
613 | (lambda (exp) | |
614 | (macroexp-let2 macroexp-copyable-p v exp | |
615 | (cl-sublis (cons (cons (car (nth 2 cl-gv)) v) | |
616 | substs) | |
617 | (nth 3 cl-gv)))))))) | |
618 | ||
619 | (defmacro define-setf-expander (name arglist &rest body) | |
620 | "Define a `setf' method. | |
621 | This method shows how to handle `setf's to places of the form (NAME ARGS...). | |
622 | The argument forms ARGS are bound according to ARGLIST, as if NAME were | |
623 | going to be expanded as a macro, then the BODY forms are executed and must | |
624 | return a list of five elements: a temporary-variables list, a value-forms | |
625 | list, a store-variables list (of length one), a store-form, and an access- | |
626 | form. See `gv-define-expander', `gv-define-setter', and `gv-define-expander' | |
627 | for a better and simpler ways to define setf-methods." | |
628 | (declare (debug | |
629 | (&define name cl-lambda-list cl-declarations-or-string def-body))) | |
630 | `(progn | |
631 | ,@(if (stringp (car body)) | |
632 | (list `(put ',name 'setf-documentation ,(pop body)))) | |
633 | (gv-define-expander ,name | |
634 | (cl-function | |
635 | (lambda (do ,@arglist) | |
636 | (cl--gv-adapt (progn ,@body) do)))))) | |
637 | ||
638 | (defmacro defsetf (name arg1 &rest args) | |
639 | "Define a `setf' method. | |
640 | This macro is an easy-to-use substitute for `define-setf-expander' that works | |
641 | well for simple place forms. In the simple `defsetf' form, `setf's of | |
642 | the form (setf (NAME ARGS...) VAL) are transformed to function or macro | |
643 | calls of the form (FUNC ARGS... VAL). Example: | |
644 | ||
645 | (cl-defsetf aref aset) | |
646 | ||
647 | Alternate form: (cl-defsetf NAME ARGLIST (STORE) BODY...). | |
648 | Here, the above `setf' call is expanded by binding the argument forms ARGS | |
649 | according to ARGLIST, binding the value form VAL to STORE, then executing | |
650 | BODY, which must return a Lisp form that does the necessary `setf' operation. | |
651 | Actually, ARGLIST and STORE may be bound to temporary variables which are | |
652 | introduced automatically to preserve proper execution order of the arguments. | |
653 | Example: | |
654 | ||
655 | (cl-defsetf nth (n x) (v) `(setcar (nthcdr ,n ,x) ,v)) | |
656 | ||
657 | \(fn NAME [FUNC | ARGLIST (STORE) BODY...])" | |
658 | (declare (debug | |
659 | (&define name | |
660 | [&or [symbolp &optional stringp] | |
661 | [cl-lambda-list (symbolp)]] | |
662 | cl-declarations-or-string def-body))) | |
663 | (if (and (listp arg1) (consp args)) | |
664 | ;; Like `gv-define-setter' but with `cl-function'. | |
665 | `(gv-define-expander ,name | |
666 | (lambda (do &rest args) | |
667 | (gv--defsetter ',name | |
668 | (cl-function | |
669 | (lambda (,@(car args) ,@arg1) ,@(cdr args))) | |
670 | do args))) | |
671 | `(gv-define-simple-setter ,name ,arg1))) | |
672 | ||
673 | ;; FIXME: CL used to provide a setf method for `apply', but I haven't been able | |
674 | ;; to find a case where it worked. The code below tries to handle it as well. | |
675 | ;; (defun cl--setf-apply (form last-witness last) | |
676 | ;; (cond | |
677 | ;; ((not (consp form)) form) | |
678 | ;; ((eq (ignore-errors (car (last form))) last-witness) | |
679 | ;; `(apply #',(car form) ,@(butlast (cdr form)) ,last)) | |
680 | ;; ((and (memq (car form) '(let let*)) | |
681 | ;; (rassoc (list last-witness) (cadr form))) | |
682 | ;; (let ((rebind (rassoc (list last-witness) (cadr form)))) | |
683 | ;; `(,(car form) ,(remq rebind (cadr form)) | |
684 | ;; ,@(mapcar (lambda (form) (cl--setf-apply form (car rebind) last)) | |
685 | ;; (cddr form))))) | |
686 | ;; (t (mapcar (lambda (form) (cl--setf-apply form last-witness last)) form)))) | |
687 | ;; (gv-define-setter apply (val fun &rest args) | |
688 | ;; (pcase fun (`#',(and (pred symbolp) f) (setq fun f)) | |
689 | ;; (_ (error "First arg to apply in setf is not #'SYM: %S" fun))) | |
690 | ;; (let* ((butlast (butlast args)) | |
691 | ;; (last (car (last args))) | |
692 | ;; (last-witness (make-symbol "--cl-tailarg--")) | |
693 | ;; (setter (macroexpand `(setf (,fun ,@butlast ,last-witness) ,val) | |
694 | ;; macroexpand-all-environment))) | |
695 | ;; (cl--setf-apply setter last-witness last))) | |
696 | ||
697 | ||
698 | ;; FIXME: CL used to provide get-setf-method, which was used by some | |
699 | ;; setf-expanders, but now that we use gv.el, it is a lot more difficult | |
700 | ;; and in general impossible to provide get-setf-method. Hopefully, it | |
701 | ;; won't be needed. If needed, we'll have to do something nasty along the | |
702 | ;; lines of | |
703 | ;; (defun get-setf-method (place &optional env) | |
704 | ;; (let* ((witness (list 'cl-gsm)) | |
705 | ;; (expansion (gv-letplace (getter setter) place | |
706 | ;; `(,witness ,getter ,(funcall setter witness))))) | |
707 | ;; ...find "let prefix" of expansion, extract getter and setter from | |
708 | ;; ...the rest, and build the 5-tuple)) | |
709 | (make-obsolete 'get-setf-method 'gv-letplace "24.2") | |
710 | ||
711 | (defmacro define-modify-macro (name arglist func &optional doc) | |
712 | "Define a `setf'-like modify macro. | |
713 | If NAME is called, it combines its PLACE argument with the other arguments | |
714 | from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)" | |
715 | (declare (debug | |
716 | (&define name cl-lambda-list ;; should exclude &key | |
717 | symbolp &optional stringp))) | |
718 | (if (memq '&key arglist) | |
719 | (error "&key not allowed in define-modify-macro")) | |
720 | (let ((place (make-symbol "--cl-place--"))) | |
721 | `(cl-defmacro ,name (,place ,@arglist) | |
722 | ,doc | |
723 | (,(if (memq '&rest arglist) #'cl-list* #'list) | |
724 | #'cl-callf ',func ,place | |
725 | ,@(cl--arglist-args arglist))))) | |
726 | ||
727 | ;;; Additional compatibility code. | |
6fa6c4ae SM |
728 | ;; For names that were clean but really aren't needed any more. |
729 | ||
de7e2b36 SM |
730 | (define-obsolete-function-alias 'cl-macroexpand 'macroexpand "24.2") |
731 | (define-obsolete-variable-alias 'cl-macro-environment | |
732 | 'macroexpand-all-environment "24.2") | |
733 | (define-obsolete-function-alias 'cl-macroexpand-all 'macroexpand-all "24.2") | |
6fa6c4ae SM |
734 | |
735 | ;;; Hash tables. | |
736 | ;; This is just kept for compatibility with code byte-compiled by Emacs-20. | |
737 | ||
738 | ;; No idea if this might still be needed. | |
739 | (defun cl-not-hash-table (x &optional y &rest z) | |
2ee3d7f0 | 740 | (declare (obsolete nil "24.2")) |
6fa6c4ae SM |
741 | (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x)))) |
742 | ||
743 | (defvar cl-builtin-gethash (symbol-function 'gethash)) | |
de7e2b36 | 744 | (make-obsolete-variable 'cl-builtin-gethash nil "24.2") |
6fa6c4ae | 745 | (defvar cl-builtin-remhash (symbol-function 'remhash)) |
de7e2b36 | 746 | (make-obsolete-variable 'cl-builtin-remhash nil "24.2") |
6fa6c4ae | 747 | (defvar cl-builtin-clrhash (symbol-function 'clrhash)) |
de7e2b36 | 748 | (make-obsolete-variable 'cl-builtin-clrhash nil "24.2") |
6fa6c4ae SM |
749 | (defvar cl-builtin-maphash (symbol-function 'maphash)) |
750 | ||
de7e2b36 SM |
751 | (make-obsolete-variable 'cl-builtin-maphash nil "24.2") |
752 | (define-obsolete-function-alias 'cl-map-keymap 'map-keymap "24.2") | |
753 | (define-obsolete-function-alias 'cl-copy-tree 'copy-tree "24.2") | |
754 | (define-obsolete-function-alias 'cl-gethash 'gethash "24.2") | |
755 | (define-obsolete-function-alias 'cl-puthash 'puthash "24.2") | |
756 | (define-obsolete-function-alias 'cl-remhash 'remhash "24.2") | |
757 | (define-obsolete-function-alias 'cl-clrhash 'clrhash "24.2") | |
758 | (define-obsolete-function-alias 'cl-maphash 'maphash "24.2") | |
759 | (define-obsolete-function-alias 'cl-make-hash-table 'make-hash-table "24.2") | |
760 | (define-obsolete-function-alias 'cl-hash-table-p 'hash-table-p "24.2") | |
761 | (define-obsolete-function-alias 'cl-hash-table-count 'hash-table-count "24.2") | |
6fa6c4ae | 762 | |
bb3faf5b SM |
763 | (defun cl-maclisp-member (item list) |
764 | (declare (obsolete member "24.2")) | |
765 | (while (and list (not (equal item (car list)))) (setq list (cdr list))) | |
766 | list) | |
767 | ||
2ee3d7f0 SM |
768 | ;; Used in the expansion of the old `defstruct'. |
769 | (defun cl-struct-setf-expander (x name accessor pred-form pos) | |
770 | (declare (obsolete nil "24.2")) | |
771 | (let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--"))) | |
772 | (list (list temp) (list x) (list store) | |
773 | `(progn | |
774 | ,@(and pred-form | |
775 | (list `(or ,(cl-subst temp 'cl-x pred-form) | |
776 | (error ,(format | |
777 | "%s storing a non-%s" | |
778 | accessor name))))) | |
779 | ,(if (eq (car (get name 'cl-struct-type)) 'vector) | |
780 | `(aset ,temp ,pos ,store) | |
781 | `(setcar | |
782 | ,(if (<= pos 5) | |
783 | (let ((xx temp)) | |
784 | (while (>= (setq pos (1- pos)) 0) | |
785 | (setq xx `(cdr ,xx))) | |
786 | xx) | |
787 | `(nthcdr ,pos ,temp)) | |
788 | ,store))) | |
789 | (list accessor temp)))) | |
790 | ||
7467c796 | 791 | (provide 'cl) |
fcd73769 | 792 | ;;; cl.el ends here |