diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/cl-extra.el | 16 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-lib.el | 108 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-loaddefs.el | 4 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 200 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl.el | 18 | ||||
| -rw-r--r-- | lisp/emacs-lisp/gv.el | 117 |
6 files changed, 204 insertions, 259 deletions
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index e64623ab44e..b721ceba2ef 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -523,6 +523,10 @@ This sets the values of: `cl-most-positive-float', `cl-most-negative-float', "Return the subsequence of SEQ from START to END. If END is omitted, it defaults to the length of the sequence. If START or END is negative, it counts from the end." + (declare (gv-setter + (lambda (new) + `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end) + ,new)))) (if (stringp seq) (substring seq start end) (let (len) (and end (< end 0) (setq end (+ end (setq len (length seq))))) @@ -587,7 +591,8 @@ If START or END is negative, it counts from the end." (defun cl-get (sym tag &optional def) "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none. \n(fn SYMBOL PROPNAME &optional DEFAULT)" - (declare (compiler-macro cl--compiler-macro-get)) + (declare (compiler-macro cl--compiler-macro-get) + (gv-setter (lambda (store) `(put ,sym ,tag ,store)))) (or (get sym tag) (and def ;; Make sure `def' is really absent as opposed to set to nil. @@ -602,6 +607,15 @@ If START or END is negative, it counts from the end." "Search PROPLIST for property PROPNAME; return its value or DEFAULT. PROPLIST is a list of the sort returned by `symbol-plist'. \n(fn PROPLIST PROPNAME &optional DEFAULT)" + (declare (gv-expander + (lambda (do) + (gv-letplace (getter setter) plist + (macroexp-let2 nil k tag + (macroexp-let2 nil d def + (funcall do `(cl-getf ,getter ,k ,d) + (lambda (v) + (funcall setter + `(cl--set-getf ,getter ,k ,v)))))))))) (setplist '--cl-getf-symbol-- plist) (or (get '--cl-getf-symbol-- tag) ;; Originally we called cl-get here, diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 2422aa8fbb6..990e66d91aa 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -378,26 +378,32 @@ SEQ, this is like `mapcar'. With several, it is like the Common Lisp (defsubst cl-fifth (x) "Return the fifth element of the list X." + (declare (gv-setter (lambda (store) `(setcar (nthcdr 4 ,x) ,store)))) (nth 4 x)) (defsubst cl-sixth (x) "Return the sixth element of the list X." + (declare (gv-setter (lambda (store) `(setcar (nthcdr 5 ,x) ,store)))) (nth 5 x)) (defsubst cl-seventh (x) "Return the seventh element of the list X." + (declare (gv-setter (lambda (store) `(setcar (nthcdr 6 ,x) ,store)))) (nth 6 x)) (defsubst cl-eighth (x) "Return the eighth element of the list X." + (declare (gv-setter (lambda (store) `(setcar (nthcdr 7 ,x) ,store)))) (nth 7 x)) (defsubst cl-ninth (x) "Return the ninth element of the list X." + (declare (gv-setter (lambda (store) `(setcar (nthcdr 8 ,x) ,store)))) (nth 8 x)) (defsubst cl-tenth (x) "Return the tenth element of the list X." + (declare (gv-setter (lambda (store) `(setcar (nthcdr 9 ,x) ,store)))) (nth 9 x)) (defun cl-caaar (x) @@ -612,6 +618,108 @@ If ALIST is non-nil, the new pairs are prepended to it." (nconc (cl-mapcar 'cons keys values) alist)) +;;; Generalized variables. + +;; These used to be in cl-macs.el since all macros that use them (like setf) +;; were autoloaded from cl-macs.el. But now that setf, push, and pop are in +;; core Elisp, they need to either be right here or be autoloaded via +;; cl-loaddefs.el, which is more trouble than it is worth. + +;; Some more Emacs-related place types. +(gv-define-simple-setter buffer-file-name set-visited-file-name t) +(gv-define-setter buffer-modified-p (flag &optional buf) + `(with-current-buffer ,buf + (set-buffer-modified-p ,flag))) +(gv-define-simple-setter buffer-name rename-buffer t) +(gv-define-setter buffer-string (store) + `(progn (erase-buffer) (insert ,store))) +(gv-define-simple-setter buffer-substring cl--set-buffer-substring) +(gv-define-simple-setter current-buffer set-buffer) +(gv-define-simple-setter current-case-table set-case-table) +(gv-define-simple-setter current-column move-to-column t) +(gv-define-simple-setter current-global-map use-global-map t) +(gv-define-setter current-input-mode (store) + `(progn (apply #'set-input-mode ,store) ,store)) +(gv-define-simple-setter current-local-map use-local-map t) +(gv-define-simple-setter current-window-configuration + set-window-configuration t) +(gv-define-simple-setter default-file-modes set-default-file-modes t) +(gv-define-simple-setter documentation-property put) +(gv-define-setter face-background (x f &optional s) + `(set-face-background ,f ,x ,s)) +(gv-define-setter face-background-pixmap (x f &optional s) + `(set-face-background-pixmap ,f ,x ,s)) +(gv-define-setter face-font (x f &optional s) `(set-face-font ,f ,x ,s)) +(gv-define-setter face-foreground (x f &optional s) + `(set-face-foreground ,f ,x ,s)) +(gv-define-setter face-underline-p (x f &optional s) + `(set-face-underline-p ,f ,x ,s)) +(gv-define-simple-setter file-modes set-file-modes t) +(gv-define-simple-setter frame-height set-screen-height t) +(gv-define-simple-setter frame-parameters modify-frame-parameters t) +(gv-define-simple-setter frame-visible-p cl--set-frame-visible-p) +(gv-define-simple-setter frame-width set-screen-width t) +(gv-define-simple-setter getenv setenv t) +(gv-define-simple-setter get-register set-register) +(gv-define-simple-setter global-key-binding global-set-key) +(gv-define-simple-setter local-key-binding local-set-key) +(gv-define-simple-setter mark set-mark t) +(gv-define-simple-setter mark-marker set-mark t) +(gv-define-simple-setter marker-position set-marker t) +(gv-define-setter mouse-position (store scr) + `(set-mouse-position ,scr (car ,store) (cadr ,store) + (cddr ,store))) +(gv-define-simple-setter point goto-char) +(gv-define-simple-setter point-marker goto-char t) +(gv-define-setter point-max (store) + `(progn (narrow-to-region (point-min) ,store) ,store)) +(gv-define-setter point-min (store) + `(progn (narrow-to-region ,store (point-max)) ,store)) +(gv-define-setter read-mouse-position (store scr) + `(set-mouse-position ,scr (car ,store) (cdr ,store))) +(gv-define-simple-setter screen-height set-screen-height t) +(gv-define-simple-setter screen-width set-screen-width t) +(gv-define-simple-setter selected-window select-window) +(gv-define-simple-setter selected-screen select-screen) +(gv-define-simple-setter selected-frame select-frame) +(gv-define-simple-setter standard-case-table set-standard-case-table) +(gv-define-simple-setter syntax-table set-syntax-table) +(gv-define-simple-setter visited-file-modtime set-visited-file-modtime t) +(gv-define-setter window-height (store) + `(progn (enlarge-window (- ,store (window-height))) ,store)) +(gv-define-setter window-width (store) + `(progn (enlarge-window (- ,store (window-width)) t) ,store)) +(gv-define-simple-setter x-get-secondary-selection x-own-secondary-selection t) +(gv-define-simple-setter x-get-selection x-own-selection t) + +;; More complex setf-methods. + +;; This is a hack that allows (setf (eq a 7) B) to mean either +;; (setq a 7) or (setq a nil) depending on whether B is nil or not. +;; This is useful when you have control over the PLACE but not over +;; the VALUE, as is the case in define-minor-mode's :variable. +;; It turned out that :variable needed more flexibility anyway, so +;; this doesn't seem too useful now. +(gv-define-expander eq + (lambda (do place val) + (gv-letplace (getter setter) place + (macroexp-let2 nil val val + (funcall do `(eq ,getter ,val) + (lambda (v) + `(cond + (,v ,(funcall setter val)) + ((eq ,getter ,val) ,(funcall setter `(not ,val)))))))))) + +(gv-define-expander substring + (lambda (do place from &optional to) + (gv-letplace (getter setter) place + (macroexp-let2 nil start from + (macroexp-let2 nil end to + (funcall do `(substring ,getter ,start ,end) + (lambda (v) + (funcall setter `(cl--set-substring + ,getter ,start ,end ,v))))))))) + ;;; Miscellaneous. ;;;###autoload diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 220715e6a9b..79f4d775e1a 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -11,7 +11,7 @@ ;;;;;; cl--set-frame-visible-p cl--map-overlays cl--map-intervals ;;;;;; cl--map-keymap-recursively cl-notevery cl-notany cl-every ;;;;;; cl-some cl-mapcon cl-mapcan cl-mapl cl-maplist cl-map cl--mapcar-many -;;;;;; cl-equalp cl-coerce) "cl-extra" "cl-extra.el" "edc8a08741d81c74be36b27664d3555a") +;;;;;; cl-equalp cl-coerce) "cl-extra" "cl-extra.el" "25963dec757a527e3be3ba7f7abc49ee") ;;; Generated autoloads from cl-extra.el (autoload 'cl-coerce "cl-extra" "\ @@ -265,7 +265,7 @@ Remove from SYMBOL's plist the property PROPNAME and its value. ;;;;;; cl-return cl-block cl-etypecase cl-typecase cl-ecase cl-case ;;;;;; cl-load-time-value cl-eval-when cl-destructuring-bind cl-function ;;;;;; cl-defmacro cl-defun cl-gentemp cl-gensym) "cl-macs" "cl-macs.el" -;;;;;; "e37cb1001378ce1d677b67760fb6994b") +;;;;;; "66d8d151a97f91a79ebe3d1a9d699483") ;;; Generated autoloads from cl-macs.el (autoload 'cl-gensym "cl-macs" "\ diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 234879c9cc3..d4bd73827d2 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -110,20 +110,6 @@ (defun cl--const-expr-val (x) (and (macroexp-const-p x) (if (consp x) (nth 1 x) x))) -(defun cl-expr-access-order (x v) - ;; This apparently tries to return nil iff the expression X evaluates - ;; the variables V in the same order as they appear in V (so as to - ;; be able to replace those vars with the expressions they're bound - ;; to). - ;; FIXME: This is very naive, it doesn't even check to see if those - ;; variables appear more than once. - (if (macroexp-const-p x) v - (if (consp x) - (progn - (while (setq x (cdr x)) (setq v (cl-expr-access-order (car x) v))) - v) - (if (eq x (car v)) (cdr v) '(t))))) - (defun cl--expr-contains (x y) "Count number of times X refers to Y. Return nil for 0 times." ;; FIXME: This is naive, and it will cl-count Y as referred twice in @@ -1489,30 +1475,9 @@ An implicit nil block is established around the loop. \(fn (VAR LIST [RESULT]) BODY...)" (declare (debug ((symbolp form &optional form) cl-declarations body))) - (let ((temp (make-symbol "--cl-dolist-temp--"))) - ;; FIXME: Copy&pasted from subr.el. - `(cl-block nil - ;; This is not a reliable test, but it does not matter because both - ;; semantics are acceptable, tho one is slightly faster with dynamic - ;; scoping and the other is slightly faster (and has cleaner semantics) - ;; with lexical scoping. - ,(if lexical-binding - `(let ((,temp ,(nth 1 spec))) - (while ,temp - (let ((,(car spec) (car ,temp))) - ,@body - (setq ,temp (cdr ,temp)))) - ,@(if (cdr (cdr spec)) - ;; FIXME: This let often leads to "unused var" warnings. - `((let ((,(car spec) nil)) ,@(cdr (cdr spec)))))) - `(let ((,temp ,(nth 1 spec)) - ,(car spec)) - (while ,temp - (setq ,(car spec) (car ,temp)) - ,@body - (setq ,temp (cdr ,temp))) - ,@(if (cdr (cdr spec)) - `((setq ,(car spec) nil) ,@(cddr spec)))))))) + `(cl-block nil + (,(if (eq 'cl-dolist (symbol-function 'dolist)) 'cl--dolist 'dolist) + ,spec ,@body))) ;;;###autoload (defmacro cl-dotimes (spec &rest body) @@ -1523,30 +1488,9 @@ nil. \(fn (VAR COUNT [RESULT]) BODY...)" (declare (debug cl-dolist)) - (let ((temp (make-symbol "--cl-dotimes-temp--")) - (end (nth 1 spec))) - ;; FIXME: Copy&pasted from subr.el. - `(cl-block nil - ;; This is not a reliable test, but it does not matter because both - ;; semantics are acceptable, tho one is slightly faster with dynamic - ;; scoping and the other has cleaner semantics. - ,(if lexical-binding - (let ((counter '--dotimes-counter--)) - `(let ((,temp ,end) - (,counter 0)) - (while (< ,counter ,temp) - (let ((,(car spec) ,counter)) - ,@body) - (setq ,counter (1+ ,counter))) - ,@(if (cddr spec) - ;; FIXME: This let often leads to "unused var" warnings. - `((let ((,(car spec) ,counter)) ,@(cddr spec)))))) - `(let ((,temp ,end) - (,(car spec) 0)) - (while (< ,(car spec) ,temp) - ,@body - (cl-incf ,(car spec))) - ,@(cdr (cdr spec))))))) + `(cl-block nil + (,(if (eq 'cl-dotimes (symbol-function 'dotimes)) 'cl--dotimes 'dotimes) + ,spec ,@body))) ;;;###autoload (defmacro cl-do-symbols (spec &rest body) @@ -1730,7 +1674,7 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). (declare (indent 1) (debug ((&rest (symbol sexp)) cl-declarations body))) (cond ((cdr bindings) - `(cl-symbol-macrolet (,(car bindings)) + `(cl-symbol-macrolet (,(car bindings)) (cl-symbol-macrolet ,(cdr bindings) ,@body))) ((null bindings) (macroexp-progn body)) (t @@ -1740,8 +1684,8 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). (fset 'macroexpand #'cl--sm-macroexpand) ;; FIXME: For N bindings, this will traverse `body' N times! (macroexpand-all (cons 'progn body) - (cons (list (symbol-name (caar bindings)) - (cl-cadar bindings)) + (cons (list (symbol-name (caar bindings)) + (cl-cadar bindings)) macroexpand-all-environment))) (fset 'macroexpand previous-macroexpand)))))) @@ -1864,130 +1808,6 @@ See Info node `(cl)Declarations' for details." -;;; Generalized variables. - -;;; Some standard place types from Common Lisp. -(gv-define-setter cl-get (store x y &optional d) `(put ,x ,y ,store)) -(gv-define-setter cl-subseq (new seq start &optional end) - `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end) ,new)) - -;;; Various car/cdr aliases. Note that `cadr' is handled specially. -(gv-define-setter cl-fourth (store x) `(setcar (cl-cdddr ,x) ,store)) -(gv-define-setter cl-fifth (store x) `(setcar (nthcdr 4 ,x) ,store)) -(gv-define-setter cl-sixth (store x) `(setcar (nthcdr 5 ,x) ,store)) -(gv-define-setter cl-seventh (store x) `(setcar (nthcdr 6 ,x) ,store)) -(gv-define-setter cl-eighth (store x) `(setcar (nthcdr 7 ,x) ,store)) -(gv-define-setter cl-ninth (store x) `(setcar (nthcdr 8 ,x) ,store)) -(gv-define-setter cl-tenth (store x) `(setcar (nthcdr 9 ,x) ,store)) - -;;; Some more Emacs-related place types. -(gv-define-simple-setter buffer-file-name set-visited-file-name t) -(gv-define-setter buffer-modified-p (flag &optional buf) - `(with-current-buffer ,buf - (set-buffer-modified-p ,flag))) -(gv-define-simple-setter buffer-name rename-buffer t) -(gv-define-setter buffer-string (store) - `(progn (erase-buffer) (insert ,store))) -(gv-define-simple-setter buffer-substring cl--set-buffer-substring) -(gv-define-simple-setter current-buffer set-buffer) -(gv-define-simple-setter current-case-table set-case-table) -(gv-define-simple-setter current-column move-to-column t) -(gv-define-simple-setter current-global-map use-global-map t) -(gv-define-setter current-input-mode (store) - `(progn (apply #'set-input-mode ,store) ,store)) -(gv-define-simple-setter current-local-map use-local-map t) -(gv-define-simple-setter current-window-configuration set-window-configuration t) -(gv-define-simple-setter default-file-modes set-default-file-modes t) -(gv-define-simple-setter documentation-property put) -(gv-define-setter face-background (x f &optional s) `(set-face-background ,f ,x ,s)) -(gv-define-setter face-background-pixmap (x f &optional s) - `(set-face-background-pixmap ,f ,x ,s)) -(gv-define-setter face-font (x f &optional s) `(set-face-font ,f ,x ,s)) -(gv-define-setter face-foreground (x f &optional s) `(set-face-foreground ,f ,x ,s)) -(gv-define-setter face-underline-p (x f &optional s) - `(set-face-underline-p ,f ,x ,s)) -(gv-define-simple-setter file-modes set-file-modes t) -(gv-define-simple-setter frame-height set-screen-height t) -(gv-define-simple-setter frame-parameters modify-frame-parameters t) -(gv-define-simple-setter frame-visible-p cl--set-frame-visible-p) -(gv-define-simple-setter frame-width set-screen-width t) -(gv-define-simple-setter getenv setenv t) -(gv-define-simple-setter get-register set-register) -(gv-define-simple-setter global-key-binding global-set-key) -(gv-define-simple-setter local-key-binding local-set-key) -(gv-define-simple-setter mark set-mark t) -(gv-define-simple-setter mark-marker set-mark t) -(gv-define-simple-setter marker-position set-marker t) -(gv-define-setter mouse-position (store scr) - `(set-mouse-position ,scr (car ,store) (cadr ,store) - (cddr ,store))) -(gv-define-simple-setter point goto-char) -(gv-define-simple-setter point-marker goto-char t) -(gv-define-setter point-max (store) - `(progn (narrow-to-region (point-min) ,store) ,store)) -(gv-define-setter point-min (store) - `(progn (narrow-to-region ,store (point-max)) ,store)) -(gv-define-setter read-mouse-position (store scr) - `(set-mouse-position ,scr (car ,store) (cdr ,store))) -(gv-define-simple-setter screen-height set-screen-height t) -(gv-define-simple-setter screen-width set-screen-width t) -(gv-define-simple-setter selected-window select-window) -(gv-define-simple-setter selected-screen select-screen) -(gv-define-simple-setter selected-frame select-frame) -(gv-define-simple-setter standard-case-table set-standard-case-table) -(gv-define-simple-setter syntax-table set-syntax-table) -(gv-define-simple-setter visited-file-modtime set-visited-file-modtime t) -(gv-define-setter window-height (store) - `(progn (enlarge-window (- ,store (window-height))) ,store)) -(gv-define-setter window-width (store) - `(progn (enlarge-window (- ,store (window-width)) t) ,store)) -(gv-define-simple-setter x-get-secondary-selection x-own-secondary-selection t) -(gv-define-simple-setter x-get-selection x-own-selection t) - -;;; More complex setf-methods. - -;; This is a hack that allows (setf (eq a 7) B) to mean either -;; (setq a 7) or (setq a nil) depending on whether B is nil or not. -;; This is useful when you have control over the PLACE but not over -;; the VALUE, as is the case in define-minor-mode's :variable. -;; It turned out that :variable needed more flexibility anyway, so -;; this doesn't seem too useful now. -(gv-define-expander eq - (lambda (do place val) - (gv-letplace (getter setter) place - (macroexp-let2 nil val val - (funcall do `(eq ,getter ,val) - (lambda (v) - `(cond - (,v ,(funcall setter val)) - ((eq ,getter ,val) ,(funcall setter `(not ,val)))))))))) - -(gv-define-expander nthcdr - (lambda (do n place) - (macroexp-let2 nil idx n - (gv-letplace (getter setter) place - (funcall do `(nthcdr ,idx ,getter) - (lambda (v) `(if (<= ,idx 0) ,(funcall setter v) - (setcdr (nthcdr (1- ,idx) ,getter) ,v)))))))) - -(gv-define-expander cl-getf - (lambda (do place tag &optional def) - (gv-letplace (getter setter) place - (macroexp-let2 nil k tag - (macroexp-let2 nil d def - (funcall do `(cl-getf ,getter ,k ,d) - (lambda (v) (funcall setter `(cl--set-getf ,getter ,k ,v))))))))) - -(gv-define-expander substring - (lambda (do place from &optional to) - (gv-letplace (getter setter) place - (macroexp-let2 nil start from - (macroexp-let2 nil end to - (funcall do `(substring ,getter ,start ,end) - (lambda (v) - (funcall setter `(cl--set-substring - ,getter ,start ,end ,v))))))))) - ;;; The standard modify macros. ;; `setf' is now part of core Elisp, defined in gv.el. @@ -2571,8 +2391,6 @@ surrounded by (cl-block NAME ...). ;; Compile-time optimizations for some functions defined in this package. -;; Note that cl.el arranges to force cl-macs to be loaded at compile-time, -;; mainly to make sure these macros will be present. (defun cl--compiler-macro-member (form a list &rest keys) (let ((test (and (= (length keys) 2) (eq (car keys) :test) diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index c7a48c500c0..b17d6f4e671 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -107,6 +107,14 @@ )) (defvaralias var (intern (format "cl-%s" var)))) +;; Before overwriting subr.el's `dotimes' and `dolist', let's remember +;; them under a different name, so we can use them in our implementation +;; of `dotimes' and `dolist'. +(unless (fboundp 'cl--dotimes) + (defalias 'cl--dotimes (symbol-function 'dotimes) "The non-CL `dotimes'.")) +(unless (fboundp 'cl--dolist) + (defalias 'cl--dolist (symbol-function 'dolist) "The non-CL `dolist'.")) + (dolist (fun '( (get* . cl-get) (random* . cl-random) @@ -501,6 +509,10 @@ Unlike `flet', this macro is fully compliant with the Common Lisp standard. ;; not 100% compatible: not worth the trouble to add them to cl-lib.el, but we ;; still to support old users of cl.el. +;; FIXME: `letf' is unsatisfactory because it does not really "restore" the +;; previous state. If the getter/setter loses information, that info is +;; not recovered. + (defun cl--letf (bindings simplebinds binds body) ;; It's not quite clear what the semantics of let! should be. ;; E.g. in (let! ((PLACE1 VAL1) (PLACE2 VAL2)) BODY), while it's clear @@ -581,7 +593,9 @@ the PLACE is not modified before executing BODY. (declare (indent 1) (debug letf)) (cl--letf* bindings body)) -(defun cl--gv-adapt (cl-gv do) ;FIXME: needed during setf expansion! +(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.2. (let ((vars (nth 0 cl-gv)) (vals (nth 1 cl-gv)) (binds ()) @@ -774,7 +788,5 @@ from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)" ,store))) (list accessor temp)))) -;; FIXME: More candidates: define-modify-macro, define-setf-expander. - (provide 'cl) ;;; cl.el ends here diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index ed7c6ed1d9d..147ae5d4870 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -53,12 +53,6 @@ ;; `gv-letplace' macro) is actually much easier and more elegant than the old ;; approach which is clunky and often leads to unreadable code. -;; FIXME: `let!' is unsatisfactory because it does not really "restore" the -;; previous state. If the getter/setter loses information, that info is -;; not recovered. - -;; FIXME: Add to defun-declarations-alist. - ;; Food for thought: the syntax of places does not actually conflict with the ;; pcase patterns. The `cons' gv works just like a `(,a . ,b) pcase ;; pattern, and actually the `logand' gv is even closer since it should @@ -91,6 +85,13 @@ DO must return an Elisp expression." (funcall do place (lambda (v) `(setq ,place ,v))) (let* ((head (car place)) (gf (get head 'gv-expander))) + ;; Autoload the head, if applicable, since that might define + ;; `gv-expander'. + (when (and (null gf) (fboundp head) + (eq 'autoload (car-safe (symbol-function head)))) + (with-demoted-errors + (load (nth 1 (symbol-function head)) 'noerror 'nomsg) + (setq gf (get head 'gv-expander)))) (if gf (apply gf do (cdr place)) (let ((me (macroexpand place ;FIXME: expand one step at a time! ;; (append macroexpand-all-environment @@ -139,23 +140,30 @@ arguments as NAME. DO is a function as defined in `gv-get'." ;; cleanly without affecting the running Emacs. `(eval-and-compile (put ',name 'gv-expander ,handler))) -;; (eval-and-compile -;; (defun gv--defun-declaration (name args handler) -;; (pcase handler -;; (`(lambda (,do) . ,body) -;; `(gv-define-expander ,name (lambda (,do ,@args) ,@body))) -;; ;; (`(expand ,expander) `(gv-define-expand ,name ,expander)) -;; ;; FIXME: If `setter' is a lambda, give it a name rather -;; ;; than duplicate it at each setf use. -;; (`(setter ,setter) `(gv-define-simple-setter ,name ,setter)) -;; (`(setter (,arg) . ,body) -;; `(gv-define-setter ,name (,arg ,@args) ,@body)) -;; ;; FIXME: Should we prefer gv-define-simple-setter in this case? -;; ;;((pred symbolp) `(gv-define-expander ,name #',handler)) -;; (_ (message "Unknown gv-expander declaration %S" handler) nil))) - -;; (push `(gv-expander ,#'gv--defun-declaration) defun-declarations-alist) -;; ) +;;;###autoload +(defun gv--defun-declaration (symbol name args handler &optional fix) + `(progn + ;; No need to autoload this part, since gv-get will auto-load the + ;; function's definition before checking the `gv-expander' property. + :autoload-end + ,(pcase (cons symbol handler) + (`(gv-expander . (lambda (,do) . ,body)) + `(gv-define-expander ,name (lambda (,do ,@args) ,@body))) + (`(gv-expander . ,(pred symbolp)) + `(gv-define-expander ,name #',handler)) + (`(gv-setter . (lambda (,store) . ,body)) + `(gv-define-setter ,name (,store ,@args) ,@body)) + (`(gv-setter . ,(pred symbolp)) + `(gv-define-simple-setter ,name ,handler ,fix)) + ;; (`(expand ,expander) `(gv-define-expand ,name ,expander)) + (_ (message "Unknown %s declaration %S" symbol handler) nil)))) + +;;;###autoload +(push `(gv-expander ,(apply-partially #'gv--defun-declaration 'gv-expander)) + defun-declarations-alist) +;;;###autoload +(push `(gv-setter ,(apply-partially #'gv--defun-declaration 'gv-setter)) + defun-declarations-alist) ;; (defmacro gv-define-expand (name expander) ;; "Use EXPANDER to handle NAME as a generalized var. @@ -212,24 +220,6 @@ so as to preserve the semantics of `setf'." `(gv-define-setter ,name (val &rest args) ,(if fix-return `(list 'prog1 val ,set-call) set-call)))) -;;; CL compatibility. - -(defmacro gv-define-modify-macro (name arglist func &optional doc) - (let* ((args (copy-sequence arglist)) - (rest (memq '&rest args))) - (setq args (delq '&optional (delq '&rest args))) - `(defmacro ,name (place ,@arglist) - ,doc - (gv-letplace (getter setter) place - (macroexp-let2 nil v - ,(list '\` - (append (list func ',getter) - (mapcar (lambda (arg) (list '\, arg)) args) - (if rest (list (list '\,@ (cadr rest)))))) - (funcall setter v)))))) - -(gv-define-simple-setter gv--tree-get gv--tree-set) - ;;; Typical operations on generalized variables. ;;;###autoload @@ -251,32 +241,35 @@ The return value is the last VAL in the list. (while args (push `(setf ,(pop args) ,(pop args)) sets)) (cons 'progn (nreverse sets))))) -(defmacro gv-pushnew! (val place) - "Like `gv-push!' but only adds VAL if it's not yet in PLACE. -Presence is checked with `member'. -The return value is unspecified." - (declare (debug (form gv-place))) - (macroexp-let2 macroexp-copyable-p v val - (gv-letplace (getter setter) place - `(if (member ,v ,getter) nil - ,(funcall setter `(cons ,v ,getter)))))) - -(defmacro gv-inc! (place &optional val) - "Increment PLACE by VAL (default to 1)." - (declare (debug (gv-place &optional form))) - (gv-letplace (getter setter) place - (funcall setter `(+ ,getter ,(or val 1))))) - -(defmacro gv-dec! (place &optional val) - "Decrement PLACE by VAL (default to 1)." - (declare (debug (gv-place &optional form))) - (gv-letplace (getter setter) place - (funcall setter `(- ,getter ,(or val 1))))) +;; (defmacro gv-pushnew! (val place) +;; "Like `gv-push!' but only adds VAL if it's not yet in PLACE. +;; Presence is checked with `member'. +;; The return value is unspecified." +;; (declare (debug (form gv-place))) +;; (macroexp-let2 macroexp-copyable-p v val +;; (gv-letplace (getter setter) place +;; `(if (member ,v ,getter) nil +;; ,(funcall setter `(cons ,v ,getter)))))) + +;; (defmacro gv-inc! (place &optional val) +;; "Increment PLACE by VAL (default to 1)." +;; (declare (debug (gv-place &optional form))) +;; (gv-letplace (getter setter) place +;; (funcall setter `(+ ,getter ,(or val 1))))) + +;; (defmacro gv-dec! (place &optional val) +;; "Decrement PLACE by VAL (default to 1)." +;; (declare (debug (gv-place &optional form))) +;; (gv-letplace (getter setter) place +;; (funcall setter `(- ,getter ,(or val 1))))) ;; For Edebug, the idea is to let Edebug instrument gv-places just like it does ;; for normal expressions, and then give it a gv-expander to DTRT. ;; Maybe this should really be in edebug.el rather than here. +;; Autoload this `put' since a user might use C-u C-M-x on an expression +;; containing a non-trivial `push' even before gv.el was loaded. +;;;###autoload (put 'gv-place 'edebug-form-spec 'edebug-match-form) ;; CL did the equivalent of: ;;(gv-define-expand edebug-after (lambda (before index place) place)) |