Commit 8fb09416 authored by Stefan Monnier's avatar Stefan Monnier
Browse files

(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.
parent f8006664
......@@ -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."
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment