[Emacs-diffs] master 8fb0941: (gv-setter, gv-synthetic-place, gv-delay-error): New funs/macros

[Stefan Monnier]

branch: master
commit 8fb09416ac814c16b88971ab5d8398caf6230861
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>

    (gv-setter, gv-synthetic-place, gv-delay-error): New funs/macros
    
    * lisp/emacs-lisp/gv.el (gv-setter): New function.
    (gv-invalid-place): New error.
    (gv-get): Use them.
    (gv-synthetic-place, gv-delay-error): New places.
    * lisp/emacs-lisp/cl-generic.el (cl--generic-setf-rewrite): Remove.
    (cl-defgeneric, cl-defmethod): Use gv-setter.
---
 lisp/emacs-lisp/cl-generic.el |   35 ++++++-------------------
 lisp/emacs-lisp/gv.el         |   57 ++++++++++++++++++++++++++++++++++++-----
 2 files changed, 58 insertions(+), 34 deletions(-)

diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index a3bb7c3..619428d 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -162,18 +162,6 @@
       (defalias name (cl--generic-make-function generic)))
     generic))
 
-(defun cl--generic-setf-rewrite (name)
-  (let* ((setter (intern (format "cl-generic-setter--%s" name)))
-         (exp `(unless (eq ',setter (get ',name 'cl-generic-setter))
-                 ;; (when (get ',name 'gv-expander)
-                 ;;   (error "gv-expander conflicts with (setf %S)" ',name))
-                 (setf (get ',name 'cl-generic-setter) ',setter)
-                 (gv-define-setter ,name (val &rest args)
-                   (cons ',setter (cons val args))))))
-    ;; Make sure `setf' can be used right away, e.g. in the body of the method.
-    (eval exp t)
-    (cons setter exp)))
-
 ;;;###autoload
 (defmacro cl-defgeneric (name args &rest options-and-methods)
   "Create a generic function NAME.
@@ -211,12 +199,10 @@ BODY, if present, is used as the body of a default method.
     (when options-and-methods
       ;; Anything remaining is assumed to be a default method body.
       (push `(,args ,@options-and-methods) methods))
+    (when (eq 'setf (car-safe name))
+      (require 'gv)
+      (setq name (gv-setter (cadr name))))
     `(progn
-       ,(when (eq 'setf (car-safe name))
-          (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite
-                                           (cadr name))))
-            (setq name setter)
-            code))
        ,@(mapcar (lambda (declaration)
                    (let ((f (cdr (assq (car declaration)
                                        defun-declarations-alist))))
@@ -365,18 +351,15 @@ which case this method will be invoked when the argument 
is `eql' to VAL.
              list                       ; arguments
              [ &optional stringp ]      ; documentation string
              def-body)))                ; part to be debugged
-  (let ((qualifiers nil)
-        (setfizer (if (eq 'setf (car-safe name))
-                      ;; Call it before we call cl--generic-lambda.
-                      (cl--generic-setf-rewrite (cadr name)))))
+  (let ((qualifiers nil))
     (while (not (listp args))
       (push args qualifiers)
       (setq args (pop body)))
+    (when (eq 'setf (car-safe name))
+      (require 'gv)
+      (setq name (gv-setter (cadr name))))
     (pcase-let* ((`(,uses-cnm . ,fun) (cl--generic-lambda args body)))
       `(progn
-         ,(when setfizer
-            (setq name (car setfizer))
-            (cdr setfizer))
          ,(and (get name 'byte-obsolete-info)
                (or (not (fboundp 'byte-compile-warning-enabled-p))
                    (byte-compile-warning-enabled-p 'obsolete))
@@ -689,7 +672,6 @@ The tags should be chosen according to the following rules:
   This is because the method-cache is only indexed with the first non-nil
   tag (by order of decreasing priority).")
 
-
 (cl-defgeneric cl-generic-combine-methods (generic methods)
   "Build the effective method made of METHODS.
 It should return a function that expects the same arguments as the methods, and
@@ -703,8 +685,7 @@ methods.")
 ;; Temporary definition to let the next defmethod succeed.
 (fset 'cl-generic-generalizers
       (lambda (_specializer) (list cl--generic-t-generalizer)))
-(fset 'cl-generic-combine-methods
-      #'cl--generic-standard-method-combination)
+(fset 'cl-generic-combine-methods #'cl--generic-standard-method-combination)
 
 (cl-defmethod cl-generic-generalizers (specializer)
   "Support for the catch-all t specializer."
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index fae3bcb..e67888c 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -74,6 +74,8 @@
 ;; (defvar gv--macro-environment nil
 ;;   "Macro expanders for generalized variables.")
 
+(define-error 'gv-invalid-place "%S is not a valid place expression")
+
 ;;;###autoload
 (defun gv-get (place do)
   "Build the code that applies DO to PLACE.
@@ -84,8 +86,10 @@ and SETTER is a function which returns the code to set PLACE 
when called
 with a (not necessarily copyable) Elisp expression that returns the value to
 set it to.
 DO must return an Elisp expression."
-  (if (symbolp place)
-      (funcall do place (lambda (v) `(setq ,place ,v)))
+  (cond
+   ((symbolp place) (funcall do place (lambda (v) `(setq ,place ,v))))
+   ((not (consp place)) (signal 'gv-invalid-place (list place)))
+   (t
     (let* ((head (car place))
            (gf (function-get head 'gv-expander 'autoload)))
       (if gf (apply gf do (cdr place))
@@ -104,8 +108,19 @@ DO must return an Elisp expression."
           (if (eq me place)
               (if (and (symbolp head) (get head 'setf-method))
                   (error "Incompatible place needs recompilation: %S" head)
-                (error "%S is not a valid place expression" place))
-            (gv-get me do)))))))
+                (let* ((setter (gv-setter head)))
+                  (gv--defsetter head (lambda (&rest args) `(,setter ,@args))
+                                 do (cdr place))))
+            (gv-get me do))))))))
+
+(defun gv-setter (name)
+  ;; The name taken from Scheme's SRFI-17.  Actually, for SRFI-17, the argument
+  ;; could/should be a function value rather than a symbol.
+  "Return the symbol where the (setf NAME) function should be placed."
+  (if (get name 'gv-expander)
+      (error "gv-expander conflicts with (setf %S)" name))
+  ;; FIXME: This is wrong if `name' is uninterned (or interned elsewhere).
+  (intern (format "(setf %s)" name)))
 
 ;;;###autoload
 (defmacro gv-letplace (vars place &rest body)
@@ -158,8 +173,10 @@ arguments as NAME.  DO is a function as defined in 
`gv-get'."
 
 ;;;###autoload
 (or (assq 'gv-expander defun-declarations-alist)
-    (push `(gv-expander ,(apply-partially #'gv--defun-declaration 
'gv-expander))
-         defun-declarations-alist))
+    (let ((x `(gv-expander
+               ,(apply-partially #'gv--defun-declaration 'gv-expander))))
+      (push x macro-declarations-alist)
+      (push x defun-declarations-alist)))
 ;;;###autoload
 (or (assq 'gv-setter defun-declarations-alist)
     (push `(gv-setter ,(apply-partially #'gv--defun-declaration 'gv-setter))
@@ -282,9 +299,9 @@ The return value is the last VAL in the list.
 ;; 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-macroexpand edebug-after (lambda (before index place) place))
-
 (put 'edebug-after 'gv-expander
      (lambda (do before index place)
        (gv-letplace (getter setter) place
@@ -460,6 +477,32 @@ The return value is the last VAL in the list.
              (funcall do `(funcall (car ,gv))
                       (lambda (v) `(funcall (cdr ,gv) ,v))))))))
 
+(defmacro gv-synthetic-place (getter setter)
+  "Special place described by its setter and getter.
+GETTER and SETTER (typically obtained via `gv-letplace') get and
+set that place.  I.e. This macro allows you to do the \"reverse\" of what
+`gv-letplace' does.
+This macro only makes sense when used in a place."
+  (declare (gv-expander funcall))
+  (ignore setter)
+  getter)
+
+(defmacro gv-delay-error (place)
+  "Special place which delays the `gv-invalid-place' error to run-time.
+It behaves just like PLACE except that in case PLACE is not a valid place,
+the `gv-invalid-place' error will only be signaled at run-time when (and if)
+we try to use the setter.
+This macro only makes sense when used in a place."
+  (declare
+   (gv-expander
+    (lambda (do)
+      (condition-case err
+          (gv-get place do)
+        (gv-invalid-place
+         ;; Delay the error until we try to use the setter.
+         (funcall do place (lambda (_) `(signal ',(car err) ',(cdr err)))))))))
+  place)
+
 ;;; Even more debatable extensions.
 
 (put 'cons 'gv-expander