Provide generalized variables in core Elisp.

* lisp/emacs-lisp/gv.el: New file.
* lisp/subr.el (push, pop): Extend to generalized variables.
* lisp/loadup.el (macroexp): Unload if preloaded and uncompiled.
* lisp/emacs-lisp/cl-lib.el (cl-pop, cl-push, cl--set-nthcdr): Remove.
* lisp/emacs-lisp/cl-macs.el: Require gv.  Use gv-define-setter,
gv-define-simple-setter, and gv-define-expander.
Remove setf-methods defined in gv.  Rename cl-setf -> setf.
(cl-setf, cl-do-pop, cl-get-setf-method): Remove.
(cl-letf, cl-letf*, cl-define-modify-macro, cl-defsetf)
(cl-define-setf-expander, cl-struct-setf-expander): Move to cl.el.
(cl-remf, cl-shiftf, cl-rotatef, cl-callf, cl-callf2): Rewrite with
gv-letplace.
(cl-defstruct): Don't define setf-method any more.
* lisp/emacs-lisp/cl.el (flet): Don't autoload.
(cl--letf, letf, cl--letf*, letf*, cl--gv-adapt)
(define-setf-expander, defsetf, define-modify-macro)
(cl-struct-setf-expander): Move from cl-lib.el.
* lisp/emacs-lisp/syntax.el:
* lisp/emacs-lisp/ewoc.el:
* lisp/emacs-lisp/smie.el:
* lisp/emacs-lisp/cconv.el:
* lisp/emacs-lisp/timer.el: Rename cl-setf -> setf, cl-push -> push.
(timer--time): Use gv-define-simple-setter.
* lisp/emacs-lisp/macroexp.el (macroexp-let2): Rename from macroexp-let²
to avoid coding-system problems in subr.el.  Adjust all users.
(macroexp--maxsize, macroexp-small-p): New functions.
* lisp/emacs-lisp/bytecomp.el (byte-compile-file): Don't use cl-letf.
* lisp/scroll-bar.el (scroll-bar-mode):
* lisp/simple.el (auto-fill-mode, overwrite-mode, binary-overwrite-mode)
(normal-erase-is-backspace-mode): Don't use the `eq' place.
* lisp/winner.el (winner-configuration, winner-make-point-alist)
(winner-set-conf, winner-get-point, winner-set): Don't abuse letf.
* lisp/files.el (locate-file-completion-table): Avoid list*.

Fixes: debbugs:11657

1 files changed, 430 insertions, 0 deletions

diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
new file mode 100644
index 0000000000..ed7c6ed1d9
--- /dev/null
+++ b/lisp/emacs-lisp/gv.el
@@ -0,0 +1,430 @@
+;;; gv.el --- Generalized variables  -*- lexical-binding: t -*-
+
+;; Copyright (C) 2012  Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <[email protected]>
+;; Keywords: extensions
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This is a re-implementation of the setf machinery using a different
+;; underlying approach than the one used earlier in CL, which was based on
+;; define-setf-expander.
+;; `define-setf-expander' makes every "place-expander" return a 5-tuple
+;;   (VARS VALUES STORES GETTER SETTER)
+;; where STORES is a list with a single variable (Common-Lisp allows multiple
+;; variables for use with multiple-return-values, but this is rarely used and
+;; not applicable to Elisp).
+;; It basically says that GETTER is an expression that returns the place's
+;; value, and (lambda STORES SETTER) is an expression that assigns the value(s)
+;; passed to that function to the place, and that you need to wrap the whole
+;; thing within a `(let* ,(zip VARS VALUES) ...).
+;;
+;; Instead, we use here a higher-order approach: instead
+;; of a 5-tuple, a place-expander returns a function.
+;; If you think about types, the old approach return things of type
+;;    {vars: List Var, values: List Exp,
+;;     stores: List Var, getter: Exp, setter: Exp}
+;; whereas the new approach returns a function of type
+;;    (do: ((getter: Exp, setter: ((store: Exp) -> Exp)) -> Exp)) -> Exp.
+;; You can get the new function from the old 5-tuple with something like:
+;;    (lambda (do)
+;;       `(let* ,(zip VARS VALUES)
+;;          (funcall do GETTER (lambda ,STORES ,SETTER))))
+;; You can't easily do the reverse, because this new approach is more
+;; expressive than the old one, so we can't provide a backward-compatible
+;; get-setf-method.
+;;
+;; While it may seem intimidating for people not used to higher-order
+;; functions, you will quickly see that its use (especially with the
+;; `gv-letplace' macro) is actually much easier and more elegant than the old
+;; approach which is clunky and often leads to unreadable code.
+
+;; FIXME: `let!' is unsatisfactory because it does not really "restore" the
+;; previous state.  If the getter/setter loses information, that info is
+;; not recovered.
+
+;; FIXME: Add to defun-declarations-alist.
+
+;; Food for thought: the syntax of places does not actually conflict with the
+;; pcase patterns.  The `cons' gv works just like a `(,a . ,b) pcase
+;; pattern, and actually the `logand' gv is even closer since it should
+;; arguably fail when trying to set a value outside of the mask.
+;; Generally, places are used for destructors (gethash, aref, car, ...)
+;; whereas pcase patterns are used for constructors (backquote, constants,
+;; vectors, ...).
+
+;;; Code:
+
+(require 'macroexp)
+
+;; What we call a "gvar" is basically a function of type "(getter * setter ->
+;; code) -> code", where "getter" is code and setter is "code -> code".
+
+;; (defvar gv--macro-environment nil
+;;   "Macro expanders for generalized variables.")
+
+;;;###autoload
+(defun gv-get (place do)
+  "Build the code that applies DO to PLACE.
+PLACE must be a valid generalized variable.
+DO must be a function; it will be called with 2 arguments: GETTER and SETTER,
+where GETTER is a (copyable) Elisp expression that returns the value of PLACE,
+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)))
+    (let* ((head (car place))
+           (gf (get head 'gv-expander)))
+      (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)))
+          (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.
+              (setq me (apply (get head 'compiler-macro) place (cdr place))))
+          (if (and (eq me place) (fboundp head)
+                   (symbolp (symbol-function head)))
+              ;; Follow aliases.
+              (setq me (cons (symbol-function head) (cdr place))))
+          (if (eq me place)
+              (error "%S is not a valid place expression" place)
+            (gv-get me do)))))))
+
+;;;###autoload
+(defmacro gv-letplace (vars place &rest body)
+  "Build the code manipulating the generalized variable PLACE.
+GETTER will be bound to a copyable expression that returns the value
+of PLACE.
+SETTER will be bound to a function that takes an expression V and returns
+and new expression that sets PLACE to V.
+BODY should return some Elisp expression E manipulating PLACE via GETTER
+and SETTER.
+The returned value will then be an Elisp expression that first evaluates
+all the parts of PLACE that can be evaluated and then runs E.
+
+\(fn (GETTER SETTER) PLACE &rest BODY)"
+  (declare (indent 2) (debug (sexp form body)))
+  `(gv-get ,place (lambda ,vars ,@body)))
+
+;; Different ways to declare a generalized variable.
+;;;###autoload
+(defmacro gv-define-expander (name handler)
+  "Use HANDLER to handle NAME as a generalized var.
+NAME is a symbol: the name of a function, macro, or special form.
+HANDLER is a function which takes an argument DO followed by the same
+arguments as NAME.  DO is a function as defined in `gv-get'."
+  (declare (indent 1) (debug (sexp form)))
+  ;; Use eval-and-compile so the method can be used in the same file as it
+  ;; is defined.
+  ;; FIXME: Just like byte-compile-macro-environment, we should have something
+  ;; like byte-compile-symbolprop-environment so as to handle these things
+  ;; cleanly without affecting the running Emacs.
+  `(eval-and-compile (put ',name 'gv-expander ,handler)))
+
+;; (eval-and-compile
+;; (defun gv--defun-declaration (name args handler)
+;;   (pcase handler
+;;     (`(lambda (,do) . ,body)
+;;      `(gv-define-expander ,name (lambda (,do ,@args) ,@body)))
+;;     ;; (`(expand ,expander) `(gv-define-expand ,name ,expander))
+;;     ;; FIXME: If `setter' is a lambda, give it a name rather
+;;     ;; than duplicate it at each setf use.
+;;     (`(setter ,setter) `(gv-define-simple-setter ,name ,setter))
+;;     (`(setter (,arg) . ,body)
+;;      `(gv-define-setter ,name (,arg ,@args) ,@body))
+;;     ;; FIXME: Should we prefer gv-define-simple-setter in this case?
+;;     ;;((pred symbolp) `(gv-define-expander ,name #',handler))
+;;     (_ (message "Unknown gv-expander declaration %S" handler) nil)))
+
+;; (push `(gv-expander ,#'gv--defun-declaration) defun-declarations-alist)
+;; )
+
+;; (defmacro gv-define-expand (name expander)
+;;   "Use EXPANDER to handle NAME as a generalized var.
+;; NAME is a symbol: the name of a function, macro, or special form.
+;; EXPANDER is a function that will be called as a macro-expander to reduce
+;; uses of NAME to some other generalized variable."
+;;   (declare (debug (sexp form)))
+;;   `(eval-and-compile
+;;      (if (not (boundp 'gv--macro-environment))
+;;          (setq gv--macro-environment nil))
+;;      (push (cons ',name ,expander) gv--macro-environment)))
+
+(defun gv--defsetter (name setter do args &optional vars)
+  "Helper function used by code generated by `gv-define-setter'.
+NAME is the name of the getter function.
+SETTER is a function that generates the code for the setter.
+NAME accept ARGS as arguments and SETTER accepts (NEWVAL . ARGS).
+VARS is used internally for recursive calls."
+  (if (null args)
+      (let ((vars (nreverse vars)))
+        (funcall do `(,name ,@vars) (lambda (v) (apply setter v vars))))
+    ;; FIXME: Often it would be OK to skip this `let', but in general,
+    ;; `do' may have all kinds of side-effects.
+    (macroexp-let2 nil v (car args)
+      (gv--defsetter name setter do (cdr args) (cons v vars)))))
+
+;;;###autoload
+(defmacro gv-define-setter (name arglist &rest body)
+  "Define a setter method for generalized variable NAME.
+This macro is an easy-to-use substitute for `gv-define-expander' that works
+well for simple place forms.
+Assignments of VAL to (NAME ARGS...) are expanded by binding the argument
+forms (VAL ARGS...) according to ARGLIST, then executing BODY, which must
+return a Lisp form that does the assignment.
+Actually, ARGLIST may be bound to temporary variables which are introduced
+automatically to preserve proper execution order of the arguments.  Example:
+  (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)
+       (gv--defsetter ',name (lambda ,arglist ,@body) do args))))
+
+;;;###autoload
+(defmacro gv-define-simple-setter (name setter &optional fix-return)
+  "Define a simple setter method for generalized variable NAME.
+This macro is an easy-to-use substitute for `gv-define-expander' that works
+well for simple place forms.  Assignments of VAL to (NAME ARGS...) are
+turned into calls of the form (SETTER ARGS... VAL).
+If FIX-RETURN is non-nil, then SETTER is not assumed to return VAL and
+instead the assignment is turned into (prog1 VAL (SETTER ARGS... VAL))
+so as to preserve the semantics of `setf'."
+  (declare (debug (sexp (&or symbolp lambda-expr) &optional sexp)))
+  (let ((set-call `(cons ',setter (append args (list val)))))
+  `(gv-define-setter ,name (val &rest args)
+     ,(if fix-return `(list 'prog1 val ,set-call) set-call))))
+
+;;; CL compatibility.
+
+(defmacro gv-define-modify-macro (name arglist func &optional doc)
+  (let* ((args (copy-sequence arglist))
+         (rest (memq '&rest args)))
+    (setq args (delq '&optional (delq '&rest args)))
+    `(defmacro ,name (place ,@arglist)
+       ,doc
+       (gv-letplace (getter setter) place
+         (macroexp-let2 nil v
+             ,(list '\`
+                    (append (list func ',getter)
+                            (mapcar (lambda (arg) (list '\, arg)) args)
+                            (if rest (list (list '\,@ (cadr rest))))))
+           (funcall setter v))))))
+
+(gv-define-simple-setter gv--tree-get gv--tree-set)
+
+;;; Typical operations on generalized variables.
+
+;;;###autoload
+(defmacro setf (&rest args)
+  "Set each PLACE to the value of its VAL.
+This is a generalized version of `setq'; the PLACEs may be symbolic
+references such as (car x) or (aref x i), as well as plain symbols.
+For example, (setf (cadr x) y) is equivalent to (setcar (cdr x) y).
+The return value is the last VAL in the list.
+
+\(fn PLACE VAL PLACE VAL ...)"
+  (declare (debug (gv-place form)))
+  (if (and args (null (cddr args)))
+      (let ((place (pop args))
+            (val (car args)))
+        (gv-letplace (_getter setter) place
+          (funcall setter val)))
+    (let ((sets nil))
+      (while args (push `(setf ,(pop args) ,(pop args)) sets))
+      (cons 'progn (nreverse sets)))))
+
+(defmacro gv-pushnew! (val place)
+  "Like `gv-push!' but only adds VAL if it's not yet in PLACE.
+Presence is checked with `member'.
+The return value is unspecified."
+  (declare (debug (form gv-place)))
+  (macroexp-let2 macroexp-copyable-p v val
+    (gv-letplace (getter setter) place
+      `(if (member ,v ,getter) nil
+         ,(funcall setter `(cons ,v ,getter))))))
+  
+(defmacro gv-inc! (place &optional val)
+  "Increment PLACE by VAL (default to 1)."
+  (declare (debug (gv-place &optional form)))
+  (gv-letplace (getter setter) place
+    (funcall setter `(+ ,getter ,(or val 1)))))
+
+(defmacro gv-dec! (place &optional val)
+  "Decrement PLACE by VAL (default to 1)."
+  (declare (debug (gv-place &optional form)))
+  (gv-letplace (getter setter) place
+    (funcall setter `(- ,getter ,(or val 1)))))
+
+;; For Edebug, the idea is to let Edebug instrument gv-places just like it does
+;; for normal expressions, and then give it a gv-expander to DTRT.
+;; Maybe this should really be in edebug.el rather than here.
+
+(put 'gv-place 'edebug-form-spec 'edebug-match-form)
+;; CL did the equivalent of:
+;;(gv-define-expand edebug-after (lambda (before index place) place))
+
+(put 'edebug-after 'gv-expander
+     (lambda (do before index place)
+       (gv-letplace (getter setter) place
+         (funcall do `(edebug-after ,before ,index ,getter)
+                  setter))))
+
+;;; The common generalized variables.
+
+(gv-define-simple-setter aref aset)
+(gv-define-simple-setter car setcar)
+(gv-define-simple-setter cdr setcdr)
+;; FIXME: add compiler-macros for `cXXr' instead!
+(gv-define-setter caar (val x) `(setcar (car ,x) ,val))
+(gv-define-setter cadr (val x) `(setcar (cdr ,x) ,val))
+(gv-define-setter cdar (val x) `(setcdr (car ,x) ,val))
+(gv-define-setter cddr (val x) `(setcdr (cdr ,x) ,val))
+(gv-define-setter elt (store seq n)
+  `(if (listp ,seq) (setcar (nthcdr ,n ,seq) ,store)
+     (aset ,seq ,n ,store)))
+(gv-define-simple-setter get put)
+(gv-define-setter gethash (val k h &optional _d) `(puthash ,k ,val ,h))
+
+;; (gv-define-expand nth (lambda (idx list) `(car (nthcdr ,idx ,list))))
+(put 'nth 'gv-expander
+     (lambda (do idx list)
+       (macroexp-let2 nil c `(nthcdr ,idx ,list)
+         (funcall do `(car ,c) (lambda (v) `(setcar ,c ,v))))))
+(gv-define-simple-setter symbol-function fset)
+(gv-define-simple-setter symbol-plist setplist)
+(gv-define-simple-setter symbol-value set)
+
+(put 'nthcdr 'gv-expander
+     (lambda (do n place)
+       (macroexp-let2 nil idx n
+         (gv-letplace (getter setter) place
+           (funcall do `(nthcdr ,idx ,getter)
+                    (lambda (v) `(if (<= ,idx 0) ,(funcall setter v)
+                              (setcdr (nthcdr (1- ,idx) ,getter) ,v))))))))
+
+;;; Elisp-specific generalized variables.
+
+(gv-define-simple-setter default-value set-default)
+(gv-define-simple-setter frame-parameter set-frame-parameter 'fix)
+(gv-define-simple-setter terminal-parameter set-terminal-parameter)
+(gv-define-simple-setter keymap-parent set-keymap-parent)
+(gv-define-simple-setter match-data set-match-data 'fix)
+(gv-define-simple-setter overlay-get overlay-put)
+(gv-define-setter overlay-start (store ov)
+  `(progn (move-overlay ,ov ,store (overlay-end ,ov)) ,store))
+(gv-define-setter overlay-end (store ov)
+  `(progn (move-overlay ,ov (overlay-start ,ov) ,store) ,store))
+(gv-define-simple-setter process-buffer set-process-buffer)
+(gv-define-simple-setter process-filter set-process-filter)
+(gv-define-simple-setter process-sentinel set-process-sentinel)
+(gv-define-simple-setter process-get process-put)
+(gv-define-simple-setter window-buffer set-window-buffer)
+(gv-define-simple-setter window-display-table set-window-display-table 'fix)
+(gv-define-simple-setter window-dedicated-p set-window-dedicated-p)
+(gv-define-simple-setter window-hscroll set-window-hscroll)
+(gv-define-simple-setter window-parameter set-window-parameter)
+(gv-define-simple-setter window-point set-window-point)
+(gv-define-simple-setter window-start set-window-start)
+
+;;; Some occasionally handy extensions.
+
+;; While several of the "places" below are not terribly useful for direct use,
+;; they can show up as the output of the macro expansion of reasonable places,
+;; such as struct-accessors.
+
+(put 'progn 'gv-expander
+     (lambda (do &rest exps)
+       (let ((start (butlast exps))
+             (end (car (last exps))))
+         (if (null start) (gv-get end do)
+           `(progn ,@start ,(gv-get end do))))))
+
+(let ((let-expander
+       (lambda (letsym)
+         (lambda (do bindings &rest body)
+           `(,letsym ,bindings
+                     ,@(macroexp-unprogn
+                        (gv-get (macroexp-progn body) do)))))))
+  (put 'let 'gv-expander (funcall let-expander 'let))
+  (put 'let* 'gv-expander (funcall let-expander 'let*)))
+
+(put 'if 'gv-expander
+     (lambda (do test then &rest else)
+       (let ((v (make-symbol "v")))
+         (if (macroexp-small-p (funcall do 'dummy (lambda (_) 'dummy)))
+             ;; This duplicates the `do' code, which is a problem if that
+             ;; code is large, but otherwise results in more efficient code.
+             `(if ,test ,(gv-get then do)
+                ,@(macroexp-unprogn (gv-get (macroexp-progn else) do)))
+           (macroexp-let2 nil b test
+             (macroexp-let2 nil
+                 gv `(if ,b ,(gv-letplace (getter setter) then
+                               `(cons (lambda () ,getter)
+                                      (lambda (,v) ,(funcall setter v))))
+                       ,(gv-letplace (getter setter) (macroexp-progn else)
+                          `(cons (lambda () ,getter)
+                                 (lambda (,v) ,(funcall setter v)))))
+               (funcall do `(funcall (car ,gv))
+                        (lambda (v) `(funcall (cdr ,gv) ,v)))))))))
+
+;;; Even more debatable extensions.
+
+(put 'cons 'gv-expander
+     (lambda (do a d)
+       (gv-letplace (agetter asetter) a
+         (gv-letplace (dgetter dsetter) d
+           (funcall do
+                    `(cons ,agetter ,dgetter)
+                    (lambda (v) `(progn
+                              ,(funcall asetter `(car ,v))
+                              ,(funcall dsetter `(cdr ,v)))))))))
+
+(put 'logand 'gv-expander
+     (lambda (do place &rest masks)
+       (gv-letplace (getter setter) place
+         (macroexp-let2 macroexp-copyable-p
+             mask (if (cdr masks) `(logand ,@masks) (car masks))
+           (funcall
+            do `(logand ,getter ,mask)
+            (lambda (v)
+              (funcall setter
+                       `(logior (logand ,v ,mask)
+                                (logand ,getter (lognot ,mask))))))))))
+
+;;; 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)))
+
+(provide 'gv)
+;;; gv.el ends here