;; (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))
- (let ((me (macroexpand place ;FIXME: expand one step at a time!
- ;; (append macroexpand-all-environment
- ;; gv--macro-environment)
- macroexpand-all-environment)))
+ (let ((me (macroexpand-1 place
+ ;; (append macroexpand-all-environment
+ ;; gv--macro-environment)
+ macroexpand-all-environment)))
(if (and (eq me place) (get head 'compiler-macro))
;; Expand compiler macros: this takes care of all the accessors
;; defined via cl-defsubst, such as cXXXr and defstruct slots.
(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))
The first arg in ARGLIST (the one that receives VAL) receives an expression
which can do arbitrary things, whereas the other arguments are all guaranteed
to be pure and copyable. Example use:
- (gv-define-setter aref (v a i) `(aset ,a ,i ,v))"
+ (gv-define-setter aref (v a i) \\=`(aset ,a ,i ,v))"
(declare (indent 2) (debug (&define name sexp body)))
`(gv-define-expander ,name
(lambda (do &rest args)
so as to preserve the semantics of `setf'."
(declare (debug (sexp (&or symbolp lambda-expr) &optional sexp)))
(when (eq 'lambda (car-safe setter))
- (message "Use `gv-define-setter' or name %s's setter function" name))
+ (message "Use ‘gv-define-setter’ or name %s's setter function" name))
`(gv-define-setter ,name (val &rest args)
,(if fix-return
`(macroexp-let2 nil v val
;; 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
(macroexp-let2 nil v val
`(with-current-buffer ,buf (set (make-local-variable ,var) ,v))))
+(gv-define-expander alist-get
+ (lambda (do key alist &optional default remove)
+ (macroexp-let2 macroexp-copyable-p k key
+ (gv-letplace (getter setter) alist
+ (macroexp-let2 nil p `(assq ,k ,getter)
+ (funcall do (if (null default) `(cdr ,p)
+ `(if ,p (cdr ,p) ,default))
+ (lambda (v)
+ (macroexp-let2 nil v v
+ (let ((set-exp
+ `(if ,p (setcdr ,p ,v)
+ ,(funcall setter
+ `(cons (setq ,p (cons ,k ,v))
+ ,getter)))))
+ (cond
+ ((null remove) set-exp)
+ ((or (eql v default)
+ (and (eq (car-safe v) 'quote)
+ (eq (car-safe default) 'quote)
+ (eql (cadr v) (cadr default))))
+ `(if ,p ,(funcall setter `(delq ,p ,getter))))
+ (t
+ `(cond
+ ((not (eql ,default ,v)) ,set-exp)
+ (,p ,(funcall setter
+ `(delq ,p ,getter)))))))))))))))
+
+
;;; Some occasionally handy extensions.
;; While several of the "places" below are not terribly useful for direct use,
(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
Note: this only works reliably with lexical binding mode, except for very
simple PLACEs such as (function-symbol 'foo) which will also work in dynamic
binding mode."
- (gv-letplace (getter setter) place
- `(cons (lambda () ,getter)
- (lambda (gv--val) ,(funcall setter 'gv--val)))))
+ (let ((code
+ (gv-letplace (getter setter) place
+ `(cons (lambda () ,getter)
+ (lambda (gv--val) ,(funcall setter 'gv--val))))))
+ (if (or lexical-binding
+ ;; If `code' still starts with `cons' then presumably gv-letplace
+ ;; did not add any new let-bindings, so the `lambda's don't capture
+ ;; any new variables. As a consequence, the code probably works in
+ ;; dynamic binding mode as well.
+ (eq (car-safe code) 'cons))
+ code
+ (macroexp--warn-and-return
+ "Use of gv-ref probably requires lexical-binding"
+ code))))
(defsubst gv-deref (ref)
"Dereference REF, returning the referenced value.
;; … => (load "gv.el") => (macroexpand-all (defsubst gv-deref …)) => (macroexpand (defun …)) => (load "gv.el")
(gv-define-setter gv-deref (v ref) `(funcall (cdr ,ref) ,v))
-;;; Vaguely related definitions that should be moved elsewhere.
-
-;; (defun alist-get (key alist)
-;; "Get the value associated to KEY in ALIST."
-;; (declare
-;; (gv-expander
-;; (lambda (do)
-;; (macroexp-let2 macroexp-copyable-p k key
-;; (gv-letplace (getter setter) alist
-;; (macroexp-let2 nil p `(assoc ,k ,getter)
-;; (funcall do `(cdr ,p)
-;; (lambda (v)
-;; `(if ,p (setcdr ,p ,v)
-;; ,(funcall setter
-;; `(cons (cons ,k ,v) ,getter)))))))))))
-;; (cdr (assoc key alist)))
+;; (defmacro gv-letref (vars place &rest body)
+;; (declare (indent 2) (debug (sexp form &rest body)))
+;; (require 'cl-lib) ;Can't require cl-lib at top-level for bootstrap reasons!
+;; (gv-letplace (getter setter) place
+;; `(cl-macrolet ((,(nth 0 vars) () ',getter)
+;; (,(nth 1 vars) (v) (funcall ',setter v)))
+;; ,@body)))
(provide 'gv)
;;; gv.el ends here