unofficial mirror of bug-gnu-emacs@gnu.org 
 help / color / mirror / code / Atom feed
blob e33a603d1b049d5efbb16021bf04cb5c25c95253 27397 bytes (raw)
name: lisp/emacs-lisp/cl.el 	 # note: path name is non-authoritative(*)

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
 
;;; cl.el --- Compatibility aliases for the old CL library.  -*- lexical-binding: t -*-

;; Copyright (C) 2012-2017 Free Software Foundation, Inc.

;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: extensions

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This is a compatibility file which provides the old names provided by CL
;; before we cleaned up its namespace usage.

;;; Code:

(require 'cl-lib)
(require 'macroexp)
(require 'gv)

;; (defun cl--rename ()
;;   (let ((vdefs ())
;;         (fdefs ())
;;         (case-fold-search nil)
;;         (files '("cl.el" "cl-macs.el" "cl-seq.el" "cl-extra.el")))
;;     (dolist (file files)
;;       (with-current-buffer (find-file-noselect file)
;;         (goto-char (point-min))
;;         (while (re-search-forward
;;                 "^(\\(def[^ \t\n]*\\) +'?\\(\\(\\sw\\|\\s_\\)+\\)" nil t)
;;           (let ((name (match-string-no-properties 2))
;;                 (type (match-string-no-properties 1)))
;;             (unless (string-match-p "\\`cl-" name)
;;               (cond
;;                ((member type '("defvar" "defconst"))
;;                 (unless (member name vdefs) (push name vdefs)))
;;                ((member type '("defun" "defsubst" "defalias" "defmacro"))
;;                 (unless (member name fdefs) (push name fdefs)))
;;                ((member type '("def-edebug-spec" "defsetf" "define-setf-method"
;;                                "define-compiler-macro"))
;;                 nil)
;;                (t (error "Unknown type %S" type))))))))
;;     (let ((re (concat "\\_<" (regexp-opt (append vdefs fdefs)) "\\_>"))
;;           (conflicts ()))
;;       (dolist (file files)
;;         (with-current-buffer (find-file-noselect file)
;;           (goto-char (point-min))
;;           (while (re-search-forward re nil t)
;;             (replace-match "cl-\\&"))
;;           (save-buffer))))
;;     (with-current-buffer (find-file-noselect "cl-rename.el")
;;       (dolist (def vdefs)
;;         (insert (format "(defvaralias '%s 'cl-%s)\n" def def)))
;;       (dolist (def fdefs)
;;         (insert (format "(defalias '%s 'cl-%s)\n" def def)))
;;       (save-buffer))))

;; (defun cl--unrename ()
;;   ;; Taken from "Naming Conventions" node of the doc.
;;   (let* ((names '(defun* defsubst* defmacro* function* member*
;;                          assoc* rassoc* get* remove* delete*
;;                          mapcar* sort* floor* ceiling* truncate*
;;                          round* mod* rem* random*))
;;          (files '("cl.el" "cl-lib.el" "cl-macs.el" "cl-seq.el" "cl-extra.el"))
;;          (re (concat "\\_<cl-" (regexp-opt (mapcar #'symbol-name names))
;;                      "\\_>")))
;;     (dolist (file files)
;;       (with-current-buffer (find-file-noselect file)
;;         (goto-char (point-min))
;;         (while (re-search-forward re nil t)
;;           (delete-region (1- (point)) (point)))
;;         (save-buffer)))))

(defun cl-unload-function ()
  "Stop unloading of the Common Lisp extensions."
  (message "Cannot unload the feature `cl'")
  ;; Stop standard unloading!
  t)

;;; Aliases to cl-lib's features.

(dolist (var '(
               ;; loop-result-var
               ;; loop-result
               ;; loop-initially
               ;; loop-finally
               ;; loop-bindings
               ;; loop-args
               ;; bind-inits
               ;; bind-block
               ;; lambda-list-keywords
               float-negative-epsilon
               float-epsilon
               least-negative-normalized-float
               least-positive-normalized-float
               least-negative-float
               least-positive-float
               most-negative-float
               most-positive-float
               ;; custom-print-functions
               ))
  (defvaralias var (intern (format "cl-%s" var))))

(dolist (fun '(
               (get* . cl-get)
               (random* . cl-random)
               (rem* . cl-rem)
               (mod* . cl-mod)
               (round* . cl-round)
               (truncate* . cl-truncate)
               (ceiling* . cl-ceiling)
               (floor* . cl-floor)
               (rassoc* . cl-rassoc)
               (assoc* . cl-assoc)
               (member* . cl-member)
               (delete* . cl-delete)
               (remove* . cl-remove)
               (defsubst* . cl-defsubst)
               (sort* . cl-sort)
               (function* . cl-function)
               (defmacro* . cl-defmacro)
               (defun* . cl-defun)
               (mapcar* . cl-mapcar)

               remprop
               getf
               tailp
               list-length
               nreconc
               revappend
               concatenate
               subseq
               random-state-p
               make-random-state
               signum
               isqrt
               lcm
               gcd
               notevery
               notany
               every
               some
               mapcon
               mapl
               maplist
               map
               equalp
               coerce
               tree-equal
               nsublis
               sublis
               nsubst-if-not
               nsubst-if
               nsubst
               subst-if-not
               subst-if
               subsetp
               nset-exclusive-or
               set-exclusive-or
               nset-difference
               set-difference
               nintersection
               intersection
               nunion
               union
               rassoc-if-not
               rassoc-if
               assoc-if-not
               assoc-if
               member-if-not
               member-if
               merge
               stable-sort
               search
               mismatch
               count-if-not
               count-if
               count
               position-if-not
               position-if
               position
               find-if-not
               find-if
               find
               nsubstitute-if-not
               nsubstitute-if
               nsubstitute
               substitute-if-not
               substitute-if
               substitute
               delete-duplicates
               remove-duplicates
               delete-if-not
               delete-if
               remove-if-not
               remove-if
               replace
               fill
               reduce
               compiler-macroexpand
               define-compiler-macro
               assert
               check-type
               typep
               deftype
               defstruct
               callf2
               callf
               letf*
               letf
               rotatef
               shiftf
               remf
               psetf
               (define-setf-method . define-setf-expander)
               the
               locally
               multiple-value-setq
               multiple-value-bind
               symbol-macrolet
               macrolet
               progv
               psetq
               do-all-symbols
               do-symbols
               do*
               do
               loop
               return-from
               return
               block
               etypecase
               typecase
               ecase
               case
               load-time-value
               eval-when
               destructuring-bind
               gentemp
               gensym
               pairlis
               acons
               subst
               adjoin
               copy-list
               ldiff
               list*
               cddddr
               cdddar
               cddadr
               cddaar
               cdaddr
               cdadar
               cdaadr
               cdaaar
               cadddr
               caddar
               cadadr
               cadaar
               caaddr
               caadar
               caaadr
               caaaar
               cdddr
               cddar
               cdadr
               cdaar
               caddr
               cadar
               caadr
               caaar
               tenth
               ninth
               eighth
               seventh
               sixth
               fifth
               fourth
               third
               endp
               rest
               second
               first
               svref
               copy-seq
               evenp
               oddp
               minusp
               plusp
               floatp-safe
               declaim
               proclaim
               nth-value
               multiple-value-call
               multiple-value-apply
               multiple-value-list
               values-list
               values
               pushnew
               decf
               incf
               ))
  (let ((new (if (consp fun) (prog1 (cdr fun) (setq fun (car fun)))
               (intern (format "cl-%s" fun)))))
    (defalias fun new)))

(defun cl--wrap-in-nil-block (fun &rest args)
  `(cl-block nil ,(apply fun args)))
(advice-add 'dolist :around #'cl--wrap-in-nil-block)
(advice-add 'dotimes :around #'cl--wrap-in-nil-block)

(defun cl--pass-args-to-cl-declare (&rest specs)
   (macroexpand `(cl-declare ,@specs)))
(advice-add 'declare :after #'cl--pass-args-to-cl-declare)

;;; Features provided a bit differently in Elisp.

;; First, the old lexical-let is now better served by `lexical-binding', tho
;; it's not 100% compatible.

(defvar cl-closure-vars nil)
(defvar cl--function-convert-cache nil)

(defun cl--function-convert (f)
  "Special macro-expander for special cases of (function F).
The two cases that are handled are:
- closure-conversion of lambda expressions for `lexical-let'.
- renaming of F when it's a function defined via `cl-labels' or `labels'."
  (require 'cl-macs)
  (declare-function cl--expr-contains-any "cl-macs" (x y))
  (declare-function cl--labels-convert "cl-macs" (f))
  (defvar cl--labels-convert-cache)
  (cond
   ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked
   ;; *after* handling `function', but we want to stop macroexpansion from
   ;; being applied infinitely, so we use a cache to return the exact `form'
   ;; being expanded even though we don't receive it.
   ((eq f (car cl--function-convert-cache)) (cdr cl--function-convert-cache))
   ((eq (car-safe f) 'lambda)
    (let ((body (mapcar (lambda (f)
                          (macroexpand-all f macroexpand-all-environment))
                        (cddr f))))
      (if (and cl-closure-vars
               (cl--expr-contains-any body cl-closure-vars))
          (let* ((new (mapcar 'cl-gensym cl-closure-vars))
                 (sub (cl-pairlis cl-closure-vars new)) (decls nil))
            (while (or (stringp (car body))
                       (eq (car-safe (car body)) 'interactive))
              (push (list 'quote (pop body)) decls))
            (put (car (last cl-closure-vars)) 'used t)
            `(list 'lambda '(&rest --cl-rest--)
                   ,@(cl-sublis sub (nreverse decls))
                   (list 'apply
                         (list 'function
                               #'(lambda ,(append new (cadr f))
                                   ,@(cl-sublis sub body)))
                         ,@(nconc (mapcar (lambda (x) `(list 'quote ,x))
                                          cl-closure-vars)
                                  '((quote --cl-rest--))))))
        (let* ((newf `(lambda ,(cadr f) ,@body))
               (res `(function ,newf)))
          (setq cl--function-convert-cache (cons newf res))
          res))))
   (t
    (cl--labels-convert f))))

(defmacro lexical-let (bindings &rest body)
  "Like `let', but lexically scoped.
The main visible difference is that lambdas inside BODY will create
lexical closures as in Common Lisp.
\n(fn BINDINGS BODY)"
  (declare (indent 1) (debug let))
  (let* ((cl-closure-vars cl-closure-vars)
	 (vars (mapcar (function
			(lambda (x)
			  (or (consp x) (setq x (list x)))
			  (push (make-symbol (format "--cl-%s--" (car x)))
				cl-closure-vars)
			  (set (car cl-closure-vars) [bad-lexical-ref])
			  (list (car x) (cadr x) (car cl-closure-vars))))
		       bindings))
	 (ebody
	  (macroexpand-all
           `(cl-symbol-macrolet
                ,(mapcar (lambda (x)
                           `(,(car x) (symbol-value ,(nth 2 x))))
                         vars)
              ,@body)
	   (cons (cons 'function #'cl--function-convert)
                 macroexpand-all-environment))))
    (if (not (get (car (last cl-closure-vars)) 'used))
        ;; Turn (let ((foo (cl-gensym)))
        ;;        (set foo <val>) ...(symbol-value foo)...)
        ;; into (let ((foo <val>)) ...(symbol-value 'foo)...).
        ;; This is good because it's more efficient but it only works with
        ;; dynamic scoping, since with lexical scoping we'd need
        ;; (let ((foo <val>)) ...foo...).
	`(progn
           ,@(mapcar (lambda (x) `(defvar ,(nth 2 x))) vars)
           (let ,(mapcar (lambda (x) (list (nth 2 x) (nth 1 x))) vars)
           ,(cl-sublis (mapcar (lambda (x)
                              (cons (nth 2 x)
                                    `',(nth 2 x)))
                            vars)
                    ebody)))
      `(let ,(mapcar (lambda (x)
                       (list (nth 2 x)
                             `(make-symbol ,(format "--%s--" (car x)))))
                     vars)
         (setf ,@(apply #'append
                        (mapcar (lambda (x)
                                  (list `(symbol-value ,(nth 2 x)) (nth 1 x)))
                                vars)))
         ,ebody))))

(defmacro lexical-let* (bindings &rest body)
  "Like `let*', but lexically scoped.
The main visible difference is that lambdas inside BODY, and in
successive bindings within BINDINGS, will create lexical closures
as in Common Lisp.  This is similar to the behavior of `let*' in
Common Lisp.
\n(fn BINDINGS BODY)"
  (declare (indent 1) (debug let))
  (if (null bindings) (cons 'progn body)
    (setq bindings (reverse bindings))
    (while bindings
      (setq body (list `(lexical-let (,(pop bindings)) ,@body))))
    (car body)))

;; This should really have some way to shadow 'byte-compile properties, etc.
(defmacro flet (bindings &rest body)
  "Make temporary overriding function definitions.
This is an analogue of a dynamically scoped `let' that operates on the function
cell of FUNCs rather than their value cell.
If you want the Common-Lisp style of `flet', you should use `cl-flet'.
The FORMs are evaluated with the specified function definitions in place,
then the definitions are undone (the FUNCs go back to their previous
definitions, or lack thereof).

\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
  (declare (indent 1) (debug cl-flet)
           (obsolete "use either `cl-flet' or `cl-letf'."  "24.3"))
  `(letf ,(mapcar
           (lambda (x)
             (if (or (and (fboundp (car x))
                          (eq (car-safe (symbol-function (car x))) 'macro))
                     (cdr (assq (car x) macroexpand-all-environment)))
                 (error "Use `labels', not `flet', to rebind macro names"))
             (let ((func `(cl-function
                           (lambda ,(cadr x)
                             (cl-block ,(car x) ,@(cddr x))))))
               (when (cl--compiling-file)
                 ;; Bug#411.  It would be nice to fix this.
                 (and (get (car x) 'byte-compile)
                      (error "Byte-compiling a redefinition of `%s' \
will not work - use `labels' instead" (symbol-name (car x))))
                 ;; FIXME This affects the rest of the file, when it
                 ;; should be restricted to the flet body.
                 (and (boundp 'byte-compile-function-environment)
                      (push (cons (car x) (eval func))
                            byte-compile-function-environment)))
               (list `(symbol-function ',(car x)) func)))
           bindings)
     ,@body))

(defmacro labels (bindings &rest body)
  "Make temporary function bindings.
Like `cl-labels' except that the lexical scoping is handled via `lexical-let'
rather than relying on `lexical-binding'."
  (declare (indent 1) (debug cl-flet) (obsolete cl-labels "24.3"))
  (let ((vars nil) (sets nil) (newenv macroexpand-all-environment))
    (dolist (binding bindings)
      ;; It's important that (not (eq (symbol-name var1) (symbol-name var2)))
      ;; because these var's *names* get added to the macro-environment.
      (let ((var (make-symbol (format "--cl-%s--" (car binding)))))
	(push var vars)
	(push `(cl-function (lambda . ,(cdr binding))) sets)
	(push var sets)
	(push (cons (car binding)
                    `(lambda (&rest cl-labels-args)
                       (cl-list* 'funcall ',var
                                 cl-labels-args)))
              newenv)))
    (macroexpand-all `(lexical-let ,vars (setq ,@sets) ,@body) newenv)))

;; Generalized variables are provided by gv.el, but some details are
;; not 100% compatible: not worth the trouble to add them to cl-lib.el, but we
;; still need to support old users of cl.el.

(defun cl--gv-adapt (cl-gv do)
  ;; This function is used by all .elc files that use define-setf-expander and
  ;; were compiled with Emacs>=24.3.
  (let ((vars (nth 0 cl-gv))
        (vals (nth 1 cl-gv))
        (binds ())
        (substs ()))
    ;; Use cl-sublis as was done in cl-setf-do-modify.
    (while vars
      (if (macroexp-copyable-p (car vals))
          (push (cons (pop vars) (pop vals)) substs)
        (push (list (pop vars) (pop vals)) binds)))
    (macroexp-let*
     binds
     (funcall do (cl-sublis substs (nth 4 cl-gv))
              ;; We'd like to do something like
              ;; (lambda ,(nth 2 cl-gv) ,(nth 3 cl-gv)).
              (lambda (exp)
                (macroexp-let2 macroexp-copyable-p v exp
                  (cl-sublis (cons (cons (car (nth 2 cl-gv)) v)
                                   substs)
                             (nth 3 cl-gv))))))))

(defmacro define-setf-expander (name arglist &rest body)
  "Define a `setf' method.
This method shows how to handle `setf's to places of the form
\(NAME ARGS...).  The argument forms ARGS are bound according to
ARGLIST, as if NAME were going to be expanded as a macro, then
the BODY forms are executed and must return a list of five elements:
a temporary-variables list, a value-forms list, a store-variables list
\(of length one), a store-form, and an access- form.

See `gv-define-expander', and `gv-define-setter' for better and
simpler ways to define setf-methods."
  (declare (debug
            (&define name cl-lambda-list cl-declarations-or-string def-body)))
  `(progn
     ,@(if (stringp (car body))
           (list `(put ',name 'setf-documentation ,(pop body))))
     (gv-define-expander ,name
       (cl-function
        (lambda (do ,@arglist)
          (cl--gv-adapt (progn ,@body) do))))))

(defmacro defsetf (name arg1 &rest args)
  "Define a `setf' method.
This macro is an easy-to-use substitute for `define-setf-expander'
that works well for simple place forms.

In the simple `defsetf' form, `setf's of the form (setf (NAME
ARGS...) VAL) are transformed to function or macro calls of the
form (FUNC ARGS... VAL).  For example:

  (defsetf aref aset)

You can replace this form with `gv-define-simple-setter'.

Alternate form: (defsetf NAME ARGLIST (STORE) BODY...).

Here, the above `setf' call is expanded by binding the argument
forms ARGS according to ARGLIST, binding the value form VAL to
STORE, then executing BODY, which must return a Lisp form that
does the necessary `setf' operation.  Actually, ARGLIST and STORE
may be bound to temporary variables which are introduced
automatically to preserve proper execution order of the arguments.
For example:

  (defsetf nth (n x) (v) \\=`(setcar (nthcdr ,n ,x) ,v))

You can replace this form with `gv-define-setter'.

\(fn NAME [FUNC | ARGLIST (STORE) BODY...])"
  (declare (debug
            (&define name
                     [&or [symbolp &optional stringp]
                          [cl-lambda-list (symbolp)]]
                     cl-declarations-or-string def-body)))
  (if (and (listp arg1) (consp args))
      ;; Like `gv-define-setter' but with `cl-function'.
      `(gv-define-expander ,name
         (lambda (do &rest args)
           (gv--defsetter ',name
                          (cl-function
                           (lambda (,@(car args) ,@arg1) ,@(cdr args)))
			  do args)))
    `(gv-define-simple-setter ,name ,arg1 ,(car args))))

;; FIXME: CL used to provide a setf method for `apply', but I haven't been able
;; to find a case where it worked.  The code below tries to handle it as well.
;; (defun cl--setf-apply (form last-witness last)
;;   (cond
;;    ((not (consp form)) form)
;;    ((eq (ignore-errors (car (last form))) last-witness)
;;     `(apply #',(car form) ,@(butlast (cdr form)) ,last))
;;    ((and (memq (car form) '(let let*))
;;          (rassoc (list last-witness) (cadr form)))
;;     (let ((rebind (rassoc (list last-witness) (cadr form))))
;;     `(,(car form) ,(remq rebind (cadr form))
;;       ,@(mapcar (lambda (form) (cl--setf-apply form (car rebind) last))
;;                 (cddr form)))))
;;    (t (mapcar (lambda (form) (cl--setf-apply form last-witness last)) form))))
;; (gv-define-setter apply (val fun &rest args)
;;   (pcase fun (`#',(and (pred symbolp) f) (setq fun f))
;;          (_ (error "First arg to apply in setf is not #'SYM: %S" fun)))
;;   (let* ((butlast (butlast args))
;;          (last (car (last args)))
;;          (last-witness (make-symbol "--cl-tailarg--"))
;;          (setter (macroexpand `(setf (,fun ,@butlast ,last-witness) ,val)
;;                               macroexpand-all-environment)))
;;     (cl--setf-apply setter last-witness last)))


;; FIXME: CL used to provide get-setf-method, which was used by some
;; setf-expanders, but now that we use gv.el, it is a lot more difficult
;; and in general impossible to provide get-setf-method.  Hopefully, it
;; won't be needed.  If needed, we'll have to do something nasty along the
;; lines of
;; (defun get-setf-method (place &optional env)
;;   (let* ((witness (list 'cl-gsm))
;;          (expansion (gv-letplace (getter setter) place
;;                      `(,witness ,getter ,(funcall setter witness)))))
;;     ...find "let prefix" of expansion, extract getter and setter from
;;     ...the rest, and build the 5-tuple))
(make-obsolete 'get-setf-method 'gv-letplace "24.3")

(declare-function cl--arglist-args "cl-macs" (args))

(defmacro define-modify-macro (name arglist func &optional doc)
  "Define a `setf'-like modify macro.
If NAME is called, it combines its PLACE argument with the other
arguments from ARGLIST using FUNC.  For example:

  (define-modify-macro incf (&optional (n 1)) +)

You can replace this macro with `gv-letplace'."
  (declare (debug
            (&define name cl-lambda-list ;; should exclude &key
                     symbolp &optional stringp)))
  (if (memq '&key arglist)
      (error "&key not allowed in define-modify-macro"))
  (require 'cl-macs)                    ;For cl--arglist-args.
  (let ((place (make-symbol "--cl-place--")))
    `(cl-defmacro ,name (,place ,@arglist)
       ,doc
       (,(if (memq '&rest arglist) #'cl-list* #'list)
        #'cl-callf ',func ,place
        ,@(cl--arglist-args arglist)))))

;;; Additional compatibility code.
;; For names that were clean but really aren't needed any more.

(define-obsolete-function-alias 'cl-macroexpand 'macroexpand "24.3")
(define-obsolete-variable-alias 'cl-macro-environment
  'macroexpand-all-environment "24.3")
(define-obsolete-function-alias 'cl-macroexpand-all 'macroexpand-all "24.3")

;;; Hash tables.
;; This is just kept for compatibility with code byte-compiled by Emacs-20.

;; No idea if this might still be needed.
(defun cl-not-hash-table (x &optional y &rest _z)
  (declare (obsolete nil "24.3"))
  (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x))))

(defvar cl-builtin-gethash (symbol-function 'gethash))
(make-obsolete-variable 'cl-builtin-gethash nil "24.3")
(defvar cl-builtin-remhash (symbol-function 'remhash))
(make-obsolete-variable 'cl-builtin-remhash nil "24.3")
(defvar cl-builtin-clrhash (symbol-function 'clrhash))
(make-obsolete-variable 'cl-builtin-clrhash nil "24.3")
(defvar cl-builtin-maphash (symbol-function 'maphash))

(make-obsolete-variable 'cl-builtin-maphash nil "24.3")
(define-obsolete-function-alias 'cl-map-keymap 'map-keymap "24.3")
(define-obsolete-function-alias 'cl-copy-tree 'copy-tree "24.3")
(define-obsolete-function-alias 'cl-gethash 'gethash "24.3")
(define-obsolete-function-alias 'cl-puthash 'puthash "24.3")
(define-obsolete-function-alias 'cl-remhash 'remhash "24.3")
(define-obsolete-function-alias 'cl-clrhash 'clrhash "24.3")
(define-obsolete-function-alias 'cl-maphash 'maphash "24.3")
(define-obsolete-function-alias 'cl-make-hash-table 'make-hash-table "24.3")
(define-obsolete-function-alias 'cl-hash-table-p 'hash-table-p "24.3")
(define-obsolete-function-alias 'cl-hash-table-count 'hash-table-count "24.3")

(define-obsolete-function-alias 'cl-map-keymap-recursively
  'cl--map-keymap-recursively "24.3")
(define-obsolete-function-alias 'cl-map-intervals 'cl--map-intervals "24.3")
(define-obsolete-function-alias 'cl-map-extents 'cl--map-overlays "24.3")
(define-obsolete-function-alias 'cl-set-getf 'cl--set-getf "24.3")

(defun cl-maclisp-member (item list)
  (declare (obsolete member "24.3"))
  (while (and list (not (equal item (car list)))) (setq list (cdr list)))
  list)

;; Used in the expansion of the old `defstruct'.
(defun cl-struct-setf-expander (x name accessor pred-form pos)
  (declare (obsolete nil "24.3"))
  (let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--")))
    (list (list temp) (list x) (list store)
	  `(progn
             ,@(and pred-form
                    (list `(or ,(cl-subst temp 'cl-x pred-form)
                               (error ,(format
                                        "%s storing a non-%s"
                                        accessor name)))))
             ,(if (eq (car (get name 'cl-struct-type)) 'vector)
                  `(aset ,temp ,pos ,store)
                `(setcar
                  ,(if (<= pos 5)
                       (let ((xx temp))
                         (while (>= (setq pos (1- pos)) 0)
                           (setq xx `(cdr ,xx)))
                         xx)
                     `(nthcdr ,pos ,temp))
                  ,store)))
	  (list accessor temp))))

(provide 'cl)

(run-hooks 'cl-load-hook)

;;; cl.el ends here

debug log:

solving e33a603d1b ...
found e33a603d1b in https://git.savannah.gnu.org/cgit/emacs.git

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).