(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.
(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))))
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))
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
;; 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."
;; (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.
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))
(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)
;;;###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))
;; 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
(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
projects / emacs.git / commitdiff