From 8fb09416ac814c16b88971ab5d8398caf6230861 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 7 Jul 2015 11:37:04 -0400 Subject: [PATCH] (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 a3bb7c3ad7b..619428d46bd 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 fae3bcb86f6..e67888cc060 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 -- 2.39.2