Merge remote-tracking branch 'origin/scratch/oclosure' into fcr

This is done simply so as to avoid scattering nadvice's code into
`simple.el` and `cl-print.el`.

* lisp/loadup.el ("emacs-lisp/nadvice"): Move down after "simple".

* lisp/help.el (help-command-error-confusable-suggestions): Make it
call `command-error-default`.
(command-error-function): Replace the top-level call to `add-function`
with a simple `setq` since `add-function` is not available at this
stage any more.

* lisp/emacs-lisp/nadvice.el (interactive-form) <advice>:
(cl-print-object) <advice>: Rename from `advice--get-interactive-form`
and `advice--cl-print-object`.

* lisp/emacs-lisp/cl-print.el (cl-print-object) <advice>:
* lisp/simple.el (interactive-form) <advice>: Move to `nadvice.el`.
(pre-redisplay-function): Replace the top-level call to `add-function`
with a simple `setq` since `add-function` is not available at this
stage any more.

* lisp/emacs-lisp/cl-generic.el: Use `oclosure-object` instead of `advice`
as representative of the OClosure specializers to prefill the dispatcher table.

lisp/ansi-color.el

@@ -414,7 +414,7 @@ and it should apply face FACE to the text between BEG and END.")
   (setq ansi-color-for-comint-mode 'filter))
 
 ;;;###autoload
-(defun ansi-color-process-output (ignored)
+(defun ansi-color-process-output (_ignored)
   "Maybe translate SGR control sequences of comint output into text properties.
 
 Depending on variable `ansi-color-for-comint-mode' the comint output is

lisp/calendar/icalendar.el

@@ -645,10 +645,10 @@ FIXME: multiple comma-separated values should be allowed!"
           (setq second (read (substring isodatetimestring 13 15))))
 	;; FIXME: Support subseconds.
         (when (> (length isodatetimestring) 15)
-          (cl-case (aref isodatetimestring 15)
+          (pcase (aref isodatetimestring 15)
             (?Z
              (setq source-zone t))
-            ((?- ?+)
+            ((or ?- ?+)
              (setq source-zone
                    (concat "UTC" (substring isodatetimestring 15))))))
         ;; shift if necessary

lisp/cus-edit.el

@@ -1511,7 +1511,7 @@ If TYPE is `groups', include only groups."
      "*Customize Apropos*")))
 
 ;;;###autoload
-(defun customize-apropos-options (regexp &optional ignored)
+(defun customize-apropos-options (regexp &optional _ignored)
   "Customize all loaded customizable options matching REGEXP."
   (interactive (list (apropos-read-pattern "options")))
   (customize-apropos regexp 'options))

lisp/cus-theme.el

@@ -142,7 +142,7 @@ remove them from your saved Custom file.\n\n")
     (widget-create 'push-button
 		   :tag " Revert "
 		   :help-echo "Revert this buffer to its original state."
-		   :action (lambda (&rest ignored) (revert-buffer)))
+		   :action (lambda (&rest _) (revert-buffer)))
 
     (widget-insert "\n\nTheme name : ")
     (setq custom-theme-name

lisp/dired-aux.el

@@ -3089,7 +3089,7 @@ Use \\[dired-hide-all] to (un)hide all directories."
       (dired-next-subdir 1 t))))
 
 ;;;###autoload
-(defun dired-hide-all (&optional ignored)
+(defun dired-hide-all (&optional _ignored)
   "Hide all subdirectories, leaving only their header lines.
 If there is already something hidden, make everything visible again.
 Use \\[dired-hide-subdir] to (un)hide a particular subdirectory."

lisp/edmacro.el

@@ -99,8 +99,7 @@ With a prefix argument, format the macro in a more concise way."
   (when keys
     (let ((cmd (if (arrayp keys) (key-binding keys) keys))
           (cmd-noremap (when (arrayp keys) (key-binding keys nil t)))
-	  (mac nil) (mac-counter nil) (mac-format nil)
-	  kmacro)
+	  (mac nil) (mac-counter nil) (mac-format nil))
       (cond (store-hook
 	     (setq mac keys)
 	     (setq cmd nil))
@@ -131,10 +130,10 @@ With a prefix argument, format the macro in a more concise way."
 	    (t
 	     (setq mac cmd)
 	     (setq cmd nil)))
-      (when (setq kmacro (kmacro-extract-lambda mac))
-	(setq mac (car kmacro)
-	      mac-counter (nth 1 kmacro)
-	      mac-format (nth 2 kmacro)))
+      (when (kmacro-p mac)
+	(setq mac (kmacro--keys mac)
+	      mac-counter (kmacro--counter mac)
+	      mac-format (kmacro--format mac)))
       (unless (arrayp mac)
 	(error "Key sequence %s is not a keyboard macro"
 	       (key-description keys)))
@@ -260,7 +259,7 @@ or nil, use a compact 80-column format."
 			  (push key keys)
 			  (let ((b (key-binding key)))
 			    (and b (commandp b) (not (arrayp b))
-				 (not (kmacro-extract-lambda b))
+				 (not (kmacro-p b))
 				 (or (not (fboundp b))
 				     (not (or (arrayp (symbol-function b))
 					      (get b 'kmacro))))
@@ -313,10 +312,7 @@ or nil, use a compact 80-column format."
 	    (when cmd
 	      (if (= (length mac) 0)
 		  (fmakunbound cmd)
-		(fset cmd
-		      (if (and mac-counter mac-format)
-			  (kmacro-lambda-form mac mac-counter mac-format)
-			mac))))
+		(fset cmd (kmacro mac mac-counter mac-format))))
 	    (if no-keys
 		(when cmd
 		  (cl-loop for key in (where-is-internal cmd '(keymap)) do
@@ -327,10 +323,8 @@ or nil, use a compact 80-column format."
 		  (cl-loop for key in keys do
                            (global-set-key key
                                            (or cmd
-                                               (if (and mac-counter mac-format)
-                                                   (kmacro-lambda-form
-                                                    mac mac-counter mac-format)
-                                                 mac))))))))))
+                                               (kmacro mac mac-counter
+                                                       mac-format))))))))))
       (kill-buffer buf)
       (when (buffer-name obuf)
 	(switch-to-buffer obuf))

lisp/emacs-lisp/cconv.el

@@ -201,7 +201,10 @@ Returns a form where all lambdas don't have any free variables."
          (i 0)
          (new-env ()))
     ;; Build the "formal and actual envs" for the closure-converted function.
-    (dolist (fv fvs)
+    ;; Hack for OClosure: `nreverse' here intends to put the captured vars
+    ;; in the closure such that the first one is the one that is bound
+    ;; most closely.
+    (dolist (fv (nreverse fvs))
       (let ((exp (or (cdr (assq fv env)) fv)))
         (pcase exp
           ;; If `fv' is a variable that's wrapped in a cons-cell,
@@ -240,7 +243,7 @@ Returns a form where all lambdas don't have any free variables."
   ;; this case better, we'd need to traverse the tree one more time to
   ;; collect this data, and I think that it's not worth it.
   (mapcar (lambda (mapping)
-            (if (not (eq (cadr mapping) 'apply-partially))
+            (if (not (eq (cadr mapping) #'apply-partially))
                 mapping
               (cl-assert (eq (car mapping) (nth 2 mapping)))
               `(,(car mapping)
@@ -257,9 +260,7 @@ Returns a form where all lambdas don't have any free variables."
               ;; it is often non-trivial for the programmer to avoid such
               ;; unused vars.
               (not (intern-soft var))
-              (eq ?_ (aref (symbol-name var) 0))
-	      ;; As a special exception, ignore "ignore".
-	      (eq var 'ignored))
+              (eq ?_ (aref (symbol-name var) 0)))
        (let ((suggestions (help-uni-confusable-suggestions (symbol-name var))))
          (format "Unused lexical %s `%S'%s"
                  varkind var
@@ -293,15 +294,10 @@ of converted forms."
                              (cconv-convert form env nil))
                            funcbody))
     (if wrappers
-        (let ((special-forms '()))
-          ;; Keep special forms at the beginning of the body.
-          (while (or (and (cdr funcbody) (stringp (car funcbody))) ;docstring.
-                     (memq (car-safe (car funcbody))
-                           '(interactive declare :documentation)))
-            (push (pop funcbody) special-forms))
-          (let ((body (macroexp-progn funcbody)))
+        (pcase-let ((`(,decls . ,body) (macroexp-parse-body funcbody)))
+          (let ((body (macroexp-progn body)))
             (dolist (wrapper wrappers) (setq body (funcall wrapper body)))
-            `(,@(nreverse special-forms) ,@(macroexp-unprogn body))))
+            `(,@decls ,@(macroexp-unprogn body))))
       funcbody)))
 
 (defun cconv--lifted-arg (var env)
@@ -450,6 +446,9 @@ places where they originally did not directly appear."
                  (let ((var-def (cconv--lifted-arg var env))
                        (closedsym (make-symbol (format "closed-%s" var))))
                    (setq new-env (cconv--remap-llv new-env var closedsym))
+                   ;; FIXME: `closedsym' doesn't need to be added to `extend'
+                   ;; but adding it makes it easier to write the assertion at
+                   ;; the beginning of this function.
                    (setq new-extend (cons closedsym (remq var new-extend)))
                    (push `(,closedsym ,var-def) binders-new)))
 
@@ -605,6 +604,14 @@ places where they originally did not directly appear."
 
     (`(declare . ,_) form)              ;The args don't contain code.
 
+    (`(oclosure--fix-type (ignore . ,vars) ,exp)
+     (dolist (var vars)
+       (let ((x (assq var env)))
+         (pcase (cdr x)
+           (`(car-safe . ,_) (error "Slot %S should not be mutated" var))
+           (_ (cl-assert (null (cdr x)))))))
+     (cconv-convert exp env extend))
+
     (`(,func . ,forms)
      ;; First element is function or whatever function-like forms are: or, and,
      ;; if, catch, progn, prog1, while, until

lisp/emacs-lisp/cl-generic.el

@@ -286,7 +286,9 @@ DEFAULT-BODY, if present, is used as the body of a default method.
          (progn
            (defalias ',name
              (cl-generic-define ',name ',args ',(nreverse options))
-             ,(help-add-fundoc-usage doc args))
+             ,(if (consp doc)           ;An expression rather than a constant.
+                  `(docstring-add-fundoc-usage ,doc ',args)
+                (docstring-add-fundoc-usage doc args)))
            :autoload-end
            ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method))
                      (nreverse methods)))
@@ -379,9 +381,9 @@ the specializer used will be the one returned by BODY."
                                    . ,(lambda () spec-args))
                                  macroexpand-all-environment)))
       (require 'cl-lib)        ;Needed to expand `cl-flet' and `cl-function'.
-      (when (interactive-form (cadr fun))
+      (when (assq 'interactive body)
         (message "Interactive forms unsupported in generic functions: %S"
-                 (interactive-form (cadr fun))))
+                 (assq 'interactive body)))
       ;; First macroexpand away the cl-function stuff (e.g. &key and
       ;; destructuring args, `declare' and whatnot).
       (pcase (macroexpand fun macroenv)
@@ -507,12 +509,11 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
     (pcase-let* ((`(,uses-cnm . ,fun) (cl--generic-lambda args body)))
       `(progn
          ,(and (get name 'byte-obsolete-info)
-               (or (not (fboundp 'byte-compile-warning-enabled-p))
-                   (byte-compile-warning-enabled-p 'obsolete name))
                (let* ((obsolete (get name 'byte-obsolete-info)))
                  (macroexp-warn-and-return
                   (macroexp--obsolete-warning name obsolete "generic function")
-                  nil)))
+                  nil
+                  (list 'obsolete name))))
          ;; You could argue that `defmethod' modifies rather than defines the
          ;; function, so warnings like "not known to be defined" are fair game.
          ;; But in practice, it's common to use `cl-defmethod'
@@ -600,6 +601,15 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
 
 (defvar cl--generic-dispatchers (make-hash-table :test #'equal))
 
+
+(defvar cl--generic-compiler
+  ;; Don't byte-compile the dispatchers if cl-generic itself is not
+  ;; byte compiled.  Otherwise the byte-compiler and all the code on
+  ;; which it depends needs to be usable before cl-generic is loaded,
+  ;; which imposes a significant burden on the bootstrap.
+  (if (byte-code-function-p (lambda (x) (+ x 1)))
+      #'byte-compile (lambda (exp) (eval exp t))))
+
 (defun cl--generic-get-dispatcher (dispatch)
   (with-memoization
       (gethash dispatch cl--generic-dispatchers)
@@ -642,7 +652,8 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
       ;; FIXME: For generic functions with a single method (or with 2 methods,
       ;; one of which always matches), using a tagcode + hash-table is
       ;; overkill: better just use a `cl-typep' test.
-      (byte-compile
+      (funcall
+       cl--generic-compiler
        `(lambda (generic dispatches-left methods)
           ;; FIXME: We should find a way to expand `with-memoize' once
           ;; and forall so we don't need `subr-x' when we get here.
@@ -713,9 +724,8 @@ for all those different tags in the method-cache.")
                   (list (cl--generic-name generic)))
         f))))
 
-(defun cl--generic-no-next-method-function (generic method)
-  (lambda (&rest args)
-    (apply #'cl-no-next-method generic method args)))
+(oclosure-define cl--generic-nnm
+  "Special type for `call-next-method's that just call `no-next-method'.")
 
 (defun cl-generic-call-method (generic method &optional fun)
   "Return a function that calls METHOD.
@@ -723,9 +733,7 @@ FUN is the function that should be called when METHOD calls
 `call-next-method'."
   (if (not (cl--generic-method-uses-cnm method))
       (cl--generic-method-function method)
-    (let ((met-fun (cl--generic-method-function method))
-          (next (or fun (cl--generic-no-next-method-function
-                         generic method))))
+    (let ((met-fun (cl--generic-method-function method)))
       (lambda (&rest args)
         (apply met-fun
                ;; FIXME: This sucks: passing just `next' would
@@ -733,8 +741,12 @@ FUN is the function that should be called when METHOD calls
                ;; quasi-η, but we need this to implement the
                ;; "if call-next-method is called with no
                ;; arguments, then use the previous arguments".
-               (lambda (&rest cnm-args)
-                 (apply next (or cnm-args args)))
+               (if fun
+                   (lambda (&rest cnm-args)
+                     (apply fun (or cnm-args args)))
+                 (oclosure-lambda (cl--generic-nnm) (&rest cnm-args)
+                   (apply #'cl-no-next-method generic method
+                          (or cnm-args args))))
                args)))))
 
 ;; Standard CLOS name.
@@ -870,11 +882,20 @@ those methods.")
     (setq arg-or-context `(&context . ,arg-or-context)))
   (unless (fboundp 'cl--generic-get-dispatcher)
     (require 'cl-generic))
-  (let ((fun (cl--generic-get-dispatcher
-              `(,arg-or-context
-                ,@(apply #'append
-                         (mapcar #'cl-generic-generalizers specializers))
-                ,cl--generic-t-generalizer))))
+  (let ((fun
+         ;; Let-bind cl--generic-dispatchers so we *re*compute the function
+         ;; from scratch, since the one in the cache may be non-compiled!
+         (let ((cl--generic-dispatchers (make-hash-table))
+               ;; When compiling `cl-generic' during bootstrap, make sure
+               ;; we prefill with compiled dispatchers even though the loaded
+               ;; `cl-generic' is still interpreted.
+               (cl--generic-compiler
+                (if (featurep 'bytecomp) #'byte-compile cl--generic-compiler)))
+           (cl--generic-get-dispatcher
+            `(,arg-or-context
+              ,@(apply #'append
+                       (mapcar #'cl-generic-generalizers specializers))
+              ,cl--generic-t-generalizer)))))
     ;; Recompute dispatch at run-time, since the generalizers may be slightly
     ;; different (e.g. byte-compiled rather than interpreted).
     ;; FIXME: There is a risk that the run-time generalizer is not equivalent
@@ -892,36 +913,9 @@ those methods.")
   "Standard support for :after, :before, :around, and `:extra NAME' qualifiers."
   (cl--generic-standard-method-combination generic methods))
 
-(defconst cl--generic-nnm-sample (cl--generic-no-next-method-function t t))
-(defconst cl--generic-cnm-sample
-  (funcall (cl--generic-build-combined-method
-            nil (list (cl--generic-make-method () () t #'identity)))))
-
 (defun cl--generic-isnot-nnm-p (cnm)
   "Return non-nil if CNM is the function that calls `cl-no-next-method'."
-  ;; ¡Big Gross Ugly Hack!
-  ;; `next-method-p' just sucks, we should let it die.  But EIEIO did support
-  ;; it, and some packages use it, so we need to support it.
-  (catch 'found
-    (cl-assert (function-equal cnm cl--generic-cnm-sample))
-    (if (byte-code-function-p cnm)
-        (let ((cnm-constants (aref cnm 2))
-              (sample-constants (aref cl--generic-cnm-sample 2)))
-          (dotimes (i (length sample-constants))
-            (when (function-equal (aref sample-constants i)
-                                  cl--generic-nnm-sample)
-              (throw 'found
-                     (not (function-equal (aref cnm-constants i)
-                                          cl--generic-nnm-sample))))))
-      (cl-assert (eq 'closure (car-safe cl--generic-cnm-sample)))
-      (let ((cnm-env (cadr cnm)))
-        (dolist (vb (cadr cl--generic-cnm-sample))
-          (when (function-equal (cdr vb) cl--generic-nnm-sample)
-            (throw 'found
-                   (not (function-equal (cdar cnm-env)
-                                        cl--generic-nnm-sample))))
-          (setq cnm-env (cdr cnm-env)))))
-    (error "Haven't found no-next-method-sample in cnm-sample")))
+  (not (eq (oclosure-type cnm) 'cl--generic-nnm)))
 
 ;;; Define some pre-defined generic functions, used internally.
 
@@ -1066,7 +1060,7 @@ MET-NAME is as returned by `cl--generic-load-hist-format'."
                  (let ((sclass (cl--find-class specializer))
                        (tclass (cl--find-class type)))
                    (when (and sclass tclass)
-                     (member specializer (cl--generic-class-parents tclass))))))
+                     (member specializer (cl--class-allparents tclass))))))
            (setq applies t)))
     applies))
 
@@ -1195,22 +1189,14 @@ These match if the argument is `eql' to VAL."
   ;; Use exactly the same code as for `typeof'.
   `(if ,name (type-of ,name) 'null))
 
-(defun cl--generic-class-parents (class)
-  (let ((parents ())
-        (classes (list class)))
-    ;; BFS precedence.  FIXME: Use a topological sort.
-    (while (let ((class (pop classes)))
-             (cl-pushnew (cl--class-name class) parents)
-             (setq classes
-                   (append classes
-                           (cl--class-parents class)))))
-    (nreverse parents)))
+(define-obsolete-function-alias 'cl--generic-class-parents
+  #'cl--class-allparents "29.1")
 
 (defun cl--generic-struct-specializers (tag &rest _)
   (and (symbolp tag)
        (let ((class (get tag 'cl--class)))
          (when (cl-typep class 'cl-structure-class)
-           (cl--generic-class-parents class)))))
+           (cl--class-allparents class)))))
 
 (cl-generic-define-generalizer cl--generic-struct-generalizer
   50 #'cl--generic-struct-tag
@@ -1293,6 +1279,42 @@ Used internally for the (major-mode MODE) context specializers."
                     (progn (cl-assert (null modes)) mode)
                   `(derived-mode ,mode . ,modes))))
 
+;;; Dispatch on OClosure type
+
+;; It would make sense to put this into `oclosure.el' except that when
+;; `oclosure.el' is loaded `cl-defmethod' is not available yet.
+
+(defun cl--generic-oclosure-tag (name &rest _)
+  `(oclosure-type ,name))
+
+(defun cl-generic--oclosure-specializers (tag &rest _)
+  (and (symbolp tag)
+       (let ((class (cl--find-class tag)))
+         (when (cl-typep class 'oclosure--class)
+           (cl--class-allparents class)))))
+
+(cl-generic-define-generalizer cl-generic--oclosure-generalizer
+  ;; Give slightly higher priority than the struct specializer, so that
+  ;; for a generic function with methods dispatching structs and on OClosures,
+  ;; we first try `oclosure-type' before `type-of' since `type-of' will return
+  ;; non-nil for an OClosure as well.
+  51 #'cl--generic-oclosure-tag
+  #'cl-generic--oclosure-specializers)
+
+(cl-defmethod cl-generic-generalizers :extra "oclosure-struct" (type)
+  "Support for dispatch on types defined by `oclosure-define'."
+  (or
+   (when (symbolp type)
+     ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than
+     ;; the "cl-struct-*" variants which aren't inlined, so that dispatch can
+     ;; take place without requiring cl-lib.
+     (let ((class (cl--find-class type)))
+       (and (cl-typep class 'oclosure--class)
+            (list cl-generic--oclosure-generalizer))))
+   (cl-call-next-method)))
+
+(cl--generic-prefill-dispatchers 0 oclosure-object)
+
 ;;; Support for unloading.
 
 (cl-defmethod loadhist-unload-element ((x (head cl-defmethod)))

lisp/emacs-lisp/cl-macs.el

@@ -301,24 +301,31 @@ FORM is of the form (ARGS . BODY)."
              (t ;; `simple-args' doesn't handle all the parsing that we need,
               ;; so we pass the rest to cl--do-arglist which will do
               ;; "manual" parsing.
-              (let ((slen (length simple-args)))
-                (when (memq '&optional simple-args)
-                  (cl-decf slen))
-                (setq header
+              (let ((slen (length simple-args))
+                    (usage-str
                       ;; Macro expansion can take place in the middle of
                       ;; apparently harmless computation, so it should not
                       ;; touch the match-data.
                       (save-match-data
-                        (cons (help-add-fundoc-usage
-                               (if (stringp (car header)) (pop header))
-                               ;; Be careful with make-symbol and (back)quote,
-                               ;; see bug#12884.
-                               (help--docstring-quote
-                                (let ((print-gensym nil) (print-quoted t)
-                                      (print-escape-newlines t))
-                                  (format "%S" (cons 'fn (cl--make-usage-args
-                                                          orig-args))))))
-                              header)))
+                        (docstring--quote
+                         (let ((print-gensym nil) (print-quoted t)
+                               (print-escape-newlines t))
+                           (format "%S" (cons 'fn (cl--make-usage-args
+                                                   orig-args))))))))
+                (when (memq '&optional simple-args)
+                  (cl-decf slen))
+                (setq header
+                      (cons
+                       (if (eq :documentation (car-safe (car header)))
+                           `(:documentation (docstring-add-fundoc-usage
+                                             ,(cadr (pop header))
+                                             ,usage-str))
+                         (docstring-add-fundoc-usage
+                          (if (stringp (car header)) (pop header))
+                          ;; Be careful with make-symbol and (back)quote,
+                          ;; see bug#12884.
+                          usage-str))
+                       header))
                 ;; FIXME: we'd want to choose an arg name for the &rest param
                 ;; and pass that as `expr' to cl--do-arglist, but that ends up
                 ;; generating code with a redundant let-binding, so we instead
@@ -3282,8 +3289,9 @@ the form NAME which is a shorthand for (NAME NAME)."
             (funcall orig pred1
                      (cl--defstruct-predicate t2))))
      (funcall orig pred1 pred2))))
-(advice-add 'pcase--mutually-exclusive-p
-            :around #'cl--pcase-mutually-exclusive-p)
+(when (fboundp 'advice-add)           ;Not available during bootstrap.
+  (advice-add 'pcase--mutually-exclusive-p
+              :around #'cl--pcase-mutually-exclusive-p))
 
 
 (defun cl-struct-sequence-type (struct-type)

lisp/emacs-lisp/cl-preloaded.el

@@ -305,6 +305,17 @@ supertypes from the most specific to least specific.")
 (cl-assert (cl--class-p (cl--find-class 'cl-structure-class)))
 (cl-assert (cl--class-p (cl--find-class 'cl-structure-object)))
 
+(defun cl--class-allparents (class)
+  (let ((parents ())
+        (classes (list class)))
+    ;; BFS precedence.  FIXME: Use a topological sort.
+    (while (let ((class (pop classes)))
+             (cl-pushnew (cl--class-name class) parents)
+             (setq classes
+                   (append classes
+                           (cl--class-parents class)))))
+    (nreverse parents)))
+
 ;; Make sure functions defined with cl-defsubst can be inlined even in
 ;; packages which do not require CL.  We don't put an autoload cookie
 ;; directly on that function, since those cookies only go to cl-loaddefs.

lisp/emacs-lisp/cl-print.el

@@ -221,26 +221,11 @@ into a button whose action shows the function's disassembly.")
                             'byte-code-function object)))))
   (princ ")" stream))
 
-;; This belongs in nadvice.el, of course, but some load-ordering issues make it
-;; complicated: cl-generic uses macros from cl-macs and cl-macs uses advice-add
-;; from nadvice, so nadvice needs to be loaded before cl-generic and hence
-;; can't use cl-defmethod.
-(cl-defmethod cl-print-object :extra "nadvice"
-              ((object compiled-function) stream)
-  (if (not (advice--p object))
-      (cl-call-next-method)
-    (princ "#f(advice-wrapper " stream)
-    (when (fboundp 'advice--where)
-      (princ (advice--where object) stream)
-      (princ " " stream))
-    (cl-print-object (advice--cdr object) stream)
-    (princ " " stream)
-    (cl-print-object (advice--car object) stream)
-    (let ((props (advice--props object)))
-      (when props
-        (princ " " stream)
-        (cl-print-object props stream)))
-    (princ ")" stream)))
+;; This belongs in oclosure.el, of course, but some load-ordering issues make it
+;; complicated.
+(cl-defmethod cl-print-object ((object accessor) stream)
+  ;; FIXME: η-reduce!
+  (oclosure--accessor-cl-print object stream))
 
 (cl-defmethod cl-print-object ((object cl-structure-object) stream)
   (if (and cl-print--depth (natnump print-level)

lisp/emacs-lisp/crm.el

@@ -210,7 +210,7 @@ This function is modeled after `minibuffer-complete-and-exit'."
     (if doexit (exit-minibuffer))))
 
 (defun crm--choose-completion-string (choice buffer base-position
-                                             &rest ignored)
+                                             &rest _)
   "Completion string chooser for `completing-read-multiple'.
 This is called from `choose-completion-string-functions'.
 It replaces the string that is currently being completed, without

lisp/emacs-lisp/generator.el

@@ -692,8 +692,10 @@ of values.  Callers can retrieve each value using `iter-next'."
   (declare (indent defun)
            (debug (&define lambda-list lambda-doc &rest sexp)))
   (cl-assert lexical-binding)
-  `(lambda ,arglist
-     ,(cps-generate-evaluator body)))
+  (pcase-let* ((`(,declarations . ,exps) (macroexp-parse-body body)))
+    `(lambda ,arglist
+       ,@declarations
+       ,(cps-generate-evaluator exps))))
 
 (defmacro iter-make (&rest body)
   "Return a new iterator."

lisp/emacs-lisp/macroexp.el

@@ -702,18 +702,11 @@ test of free variables in the following ways:
       (push 'skip macroexp--pending-eager-loads)
       form))
    (t
-    (condition-case err
-        (let ((macroexp--pending-eager-loads
-               (cons load-file-name macroexp--pending-eager-loads)))
-          (if full-p
-              (macroexpand-all form)
-            (macroexpand form)))
-      (error
-       ;; Hopefully this shouldn't happen thanks to the cycle detection,
-       ;; but in case it does happen, let's catch the error and give the
-       ;; code a chance to macro-expand later.
-       (message "Eager macro-expansion failure: %S" err)
-       form)))))
+    (let ((macroexp--pending-eager-loads
+           (cons load-file-name macroexp--pending-eager-loads)))
+      (if full-p
+          (macroexpand-all form)
+        (macroexpand form))))))
 
 ;; ¡¡¡ Big Ugly Hack !!!
 ;; src/bootstrap-emacs is mostly used to compile .el files, so it needs

lisp/emacs-lisp/nadvice.el

@@ -42,49 +42,46 @@
 ;; as this one), so we have to do it by hand!
 (push (purecopy '(nadvice 1 0)) package--builtin-versions)
 
+(oclosure-define (advice
+                (:copier advice--cons (cdr))
+                (:copier advice--copy (car cdr where props)))
+  car cdr where props)
+
 ;;;; Lightweight advice/hook
 (defvar advice--where-alist
-  '((:around "\300\301\302\003#\207" 5)
-    (:before "\300\301\002\"\210\300\302\002\"\207" 4)
-    (:after "\300\302\002\"\300\301\003\"\210\207" 5)
-    (:override "\300\301\002\"\207" 4)
-    (:after-until "\300\302\002\"\206\013\000\300\301\002\"\207" 4)
-    (:after-while "\300\302\002\"\205\013\000\300\301\002\"\207" 4)
-    (:before-until "\300\301\002\"\206\013\000\300\302\002\"\207" 4)
-    (:before-while "\300\301\002\"\205\013\000\300\302\002\"\207" 4)
-    (:filter-args "\300\302\301\003!\"\207" 5)
-    (:filter-return "\301\300\302\003\"!\207" 5))
+  `((:around ,(oclosure-lambda (advice (where :around)) (&rest args)
+                (apply car cdr args)))
+    (:before ,(oclosure-lambda (advice (where :before)) (&rest args)
+                (apply car args) (apply cdr args)))
+    (:after ,(oclosure-lambda (advice (where :after)) (&rest args)
+               (apply cdr args) (apply car args)))
+    (:override ,(oclosure-lambda (advice (where :override)) (&rest args)
+                  (apply car args)))
+    (:after-until ,(oclosure-lambda (advice (where :after-until)) (&rest args)
+                     (or (apply cdr args) (apply car args))))
+    (:after-while ,(oclosure-lambda (advice (where :after-while)) (&rest args)
+                     (and (apply cdr args) (apply car args))))
+    (:before-until ,(oclosure-lambda (advice (where :before-until)) (&rest args)
+                     (or (apply car args) (apply cdr args))))
+    (:before-while ,(oclosure-lambda (advice (where :before-while)) (&rest args)
+                     (and (apply car args) (apply cdr args))))
+    (:filter-args ,(oclosure-lambda (advice (where :filter-args)) (&rest args)
+                     (apply cdr (funcall car args))))
+    (:filter-return ,(oclosure-lambda (advice (where :filter-return)) (&rest args)
+                       (funcall car (apply cdr args)))))
   "List of descriptions of how to add a function.
-Each element has the form (WHERE BYTECODE STACK) where:
-  WHERE is a keyword indicating where the function is added.
-  BYTECODE is the corresponding byte-code that will be used.
-  STACK is the amount of stack space needed by the byte-code.")
-
-(defvar advice--bytecodes (mapcar #'cadr advice--where-alist))
+Each element has the form (WHERE OCL) where OCL is a \"prototype\"
+function of type `advice'.")
 
 (defun advice--p (object)
-  (and (byte-code-function-p object)
-       (eq 128 (aref object 0))
-       (memq (length object) '(5 6))
-       (memq (aref object 1) advice--bytecodes)
-       (eq #'apply (aref (aref object 2) 0))))
-
-(defsubst advice--car   (f) (aref (aref f 2) 1))
-(defsubst advice--cdr   (f) (aref (aref f 2) 2))
-(defsubst advice--props (f) (aref (aref f 2) 3))
+  ;; (eq (oclosure-type object) 'advice)
+  (cl-typep object 'advice))
 
 (defun advice--cd*r (f)
   (while (advice--p f)
     (setq f (advice--cdr f)))
   f)
 
-(defun advice--where (f)
-  (let ((bytecode (aref f 1))
-        (where nil))
-    (dolist (elem advice--where-alist)
-      (if (eq bytecode (cadr elem)) (setq where (car elem))))
-    where))
-
 (defun advice--make-single-doc (flist function macrop)
   (let ((where (advice--where flist)))
     (concat
@@ -137,7 +134,7 @@ Each element has the form (WHERE BYTECODE STACK) where:
                         ;; "[Arg list not available until function
                         ;; definition is loaded]", bug#21299
                         (if (stringp arglist) t
-                          (help--make-usage-docstring function arglist)))
+                          (docstring--make-usage-docstring function arglist)))
                     (setq origdoc (cdr usage)) (car usage)))
       (help-add-fundoc-usage (concat origdoc
                                      (if (string-suffix-p "\n" origdoc)
@@ -180,17 +177,26 @@ Each element has the form (WHERE BYTECODE STACK) where:
         `(funcall ',fspec ',(cadr ifm))
       (cadr (or iff ifm)))))
 
-(defun advice--make-1 (byte-code stack-depth function main props)
-  "Build a function value that adds FUNCTION to MAIN."
-  (let ((adv-sig (gethash main advertised-signature-table))
-        (advice
-         (apply #'make-byte-code 128 byte-code
-                (vector #'apply function main props) stack-depth nil
-                (and (or (commandp function) (commandp main))
-                     (list (advice--make-interactive-form
-                            function main))))))
-    (when adv-sig (puthash advice adv-sig advertised-signature-table))
-    advice))
+
+(cl-defmethod interactive-form ((ad advice) &optional _)
+  (let ((car (advice--car ad))
+        (cdr (advice--cdr ad)))
+    (when (or (commandp car) (commandp cdr))
+      `(interactive ,(advice--make-interactive-form car cdr)))))
+
+(cl-defmethod cl-print-object ((object advice) stream)
+  (cl-assert (advice--p object))
+  (princ "#f(advice " stream)
+  (cl-print-object (advice--car object) stream)
+  (princ " " stream)
+  (princ (advice--where object) stream)
+  (princ " " stream)
+  (cl-print-object (advice--cdr object) stream)
+  (let ((props (advice--props object)))
+    (when props
+      (princ " " stream)
+      (cl-print-object props stream)))
+  (princ ")" stream))
 
 (defun advice--make (where function main props)
   "Build a function value that adds FUNCTION to MAIN at WHERE.
@@ -201,12 +207,11 @@ WHERE is a symbol to select an entry in `advice--where-alist'."
     (if (and md (> fd md))
         ;; `function' should go deeper.
         (let ((rest (advice--make where function (advice--cdr main) props)))
-          (advice--make-1 (aref main 1) (aref main 3)
-                          (advice--car main) rest (advice--props main)))
-      (let ((desc (assq where advice--where-alist)))
-        (unless desc (error "Unknown add-function location `%S'" where))
-        (advice--make-1 (nth 1 desc) (nth 2 desc)
-                        function main props)))))
+          (advice--cons main rest))
+      (let ((proto (assq where advice--where-alist)))
+        (unless proto (error "Unknown add-function location `%S'" where))
+        (advice--copy (cadr proto)
+                      function main where props)))))
 
 (defun advice--member-p (function use-name definition)
   (let ((found nil))
@@ -232,8 +237,7 @@ WHERE is a symbol to select an entry in `advice--where-alist'."
         (if val (car val)
           (let ((nrest (advice--tweak rest tweaker)))
             (if (eq rest nrest) flist
-              (advice--make-1 (aref flist 1) (aref flist 3)
-                              first nrest props))))))))
+              (advice--cons flist nrest))))))))
 
 ;;;###autoload
 (defun advice--remove-function (flist function)
@@ -480,6 +484,8 @@ is defined as a macro, alias, command, ..."
                           (get symbol 'advice--pending))
                          (t (symbol-function symbol)))
                   function props)
+    ;; FIXME: We could use a defmethod on `function-docstring' instead,
+    ;; except when (or (not nf) (autoloadp nf))!
     (put symbol 'function-documentation `(advice--make-docstring ',symbol))
     (add-function :around (get symbol 'defalias-fset-function)
                   #'advice--defalias-fset))

lisp/emacs-lisp/oclosure.el

@@ -0,0 +1,514 @@
+;;; oclosure.el --- Open Closures       -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2015, 2021  Stefan Monnier
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Version: 0
+
+;; 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:
+
+;; A OClosure is an object that combines the properties of records
+;; with those of a function.  More specifically it is a function extended
+;; with a notion of type (e.g. for defmethod dispatch) as well as the
+;; ability to have some fields that are accessible from the outside.
+
+;; Here are some cases of "callable objects" where OClosures are used:
+;; - nadvice.el
+;; - kmacros (for cl-print and for `kmacro-extract-lambda')
+;; - cl-generic: turn `cl--generic-isnot-nnm-p' into a mere type test
+;;   (by putting the no-next-methods into their own class).
+;; - OClosure accessor functions, where the type-dispatch is used to
+;;   dynamically compute the docstring, and also to pretty them.
+;; Here are other cases of "callable objects" where OClosures could be used:
+;; - iterators (generator.el), thunks (thunk.el), streams (stream.el).
+;; - PEG rules: they're currently just functions, but they should carry
+;;   their original (macro-expanded) definition (and should be printed
+;;   differently from functions)!
+;; - documented functions: this could be a subtype of normal functions, which
+;;   simply has an additional `docstring' slot.
+;; - commands: this could be a subtype of documented functions, which simply
+;;   has an additional `interactive-form' slot.
+;; - auto-generate docstrings for cl-defstruct slot accessors instead of
+;;   storing them in the accessor itself?
+;; - SRFI-17's `setter'.
+;; - coercion wrappers, as in "Threesomes, with and without blame"
+;;   https://dl.acm.org/doi/10.1145/1706299.1706342, or
+;;   "On the Runtime Complexity of Type-Directed Unboxing"
+;;   http://sv.c.titech.ac.jp/minamide/papers.html
+;; - An efficient `negate' operation such that
+;;   (negate f) generally returns (lambda (x) (not (f x)))
+;;   but it can optimize (negate (negate f)) to f and (negate #'<) to
+;;   #'>=.
+;; - Autoloads (tho currently our bytecode functions (and hence OClosures)
+;;   are too fat for that).
+
+;; Related constructs:
+;; - `funcallable-standard-object' (FSO) in Common-Lisp.  These are different
+;;   from OClosures in that they involve an additional indirection to get
+;;   to the actual code, and that they offer the possibility of
+;;   changing (via mutation) the code associated with
+;;   an FSO.  Also the FSO's function can't directly access the FSO's
+;;   other fields, contrary to the case with OClosures where those are directly
+;;   available as local variables.
+;; - Function objects in Javascript.
+;; - Function objects in Python.
+;; - Callable/Applicable classes in OO languages, i.e. classes with
+;;   a single method called `apply' or `call'.  The most obvious
+;;   difference with OClosures (beside the fact that Callable can be
+;;   extended with additional methods) is that all instances of
+;;   a given Callable class have to use the same method, whereas every
+;;   OClosure object comes with its own code, so two OClosure objects of the
+;;   same type can have different code.  Of course, you can get the
+;;   same result by turning every `oclosure-lambda' into its own class
+;;   declaration creating an ad-hoc subclass of the specified type.
+;;   In this sense, OClosures are just a generalization of `lambda' which brings
+;;   some of the extra feature of Callable objects.
+;; - Apply hooks and "entities" in MIT Scheme
+;;   https://www.gnu.org/software/mit-scheme/documentation/stable/mit-scheme-ref/Application-Hooks.html
+;;   Apply hooks are basically the same as Common-Lisp's FSOs, and "entities"
+;;   are a variant of it where the inner function gets the FSO itself as
+;;   additional argument (a kind of "self" arg), thus making it easier
+;;   for the code to get data from the object's extra info, tho still
+;;   not as easy as with OClosures.
+;; - "entities" in Lisp Machine Lisp (LML)
+;;   https://hanshuebner.github.io/lmman/fd-clo.xml
+;;   These are arguably identical to OClosures, modulo the fact that LML doesn't
+;;   have lexically-scoped closures and uses a form of closures based on
+;;   capturing (and reinstating) dynamically scoped bindings instead.
+
+;; Naming: to replace "OClosure" we could go with
+;; - open closures
+;; - disclosures
+;; - opening
+;; - object functions/closures
+;; - structured functions/closures (strunctions, strufs)
+;; - slotfuns (slotted functions)
+
+;;; Code:
+
+;; Slots are currently immutable, tho they can be updated functionally
+;; via the "copiers": we could relax this restriction by either allowing
+;; the function itself to mutate the captured variable/slot or by providing
+;; `setf' accessors to the slots (or both), but this comes with some problems:
+;; - mutation from within the function currently would cause cconv
+;;   to perform store-conversion on the variable, so we'd either have
+;;   to prevent cconv from doing it (which might require a new bytecode op
+;;   to update the in-closure variable), or we'd have to keep track of which
+;;   slots have been store-converted so `oclosure--get' can access their value
+;;   correctly.
+;; - If the mutated variable/slot is captured by another (nested) closure
+;;   store-conversion is indispensable, so if we want to avoid store-conversion
+;;   we'd have to disallow such capture.
+
+;; TODO:
+;; - `oclosure-cl-defun', `oclosure-cl-defsubst', `oclosure-defsubst', `oclosure-define-inline'?
+;; - Use accessor in cl-defstruct
+;; - Add pcase patterns for OClosures.
+
+(eval-when-compile (require 'cl-lib))
+(eval-when-compile (require 'subr-x))   ;For `named-let'.
+
+(cl-defstruct (oclosure--class
+               (:constructor nil)
+               (:constructor oclosure--class-make ( name docstring slots parents
+                                               allparents))
+               (:include cl--class)
+               (:copier nil))
+  "Metaclass for OClosure classes."
+  (allparents nil :read-only t :type (list-of symbol)))
+
+(setf (cl--find-class 'oclosure-object)
+      (oclosure--class-make 'oclosure-object "The root parent of all OClosure classes"
+                       nil nil '(oclosure-object)))
+(defun oclosure--object-p (oclosure)
+  (let ((type (oclosure-type oclosure)))
+    (when type
+      (memq 'oclosure-object (oclosure--class-allparents (cl--find-class type))))))
+(cl-deftype oclosure-object () '(satisfies oclosure--object-p))
+
+(defun oclosure--defstruct-make-copiers (copiers slotdescs name)
+  (require 'cl-macs)            ;`cl--arglist-args' is not autoloaded.
+  (let* ((mutables '())
+         (slots (mapcar
+                 (lambda (desc)
+	           (let ((name (cl--slot-descriptor-name desc)))
+	             (unless (alist-get :read-only
+	                                (cl--slot-descriptor-props desc))
+	               (push name mutables))
+	             name))
+	         slotdescs)))
+    (mapcar
+     (lambda (copier)
+       (pcase-let*
+           ((cname (pop copier))
+            (args (or (pop copier) `(&key ,@slots)))
+            (doc (or (pop copier)
+                     (format "Copier for objects of type `%s'." name)))
+            (obj (make-symbol "obj"))
+            (absent (make-symbol "absent"))
+            (anames (cl--arglist-args args))
+            (mnames
+             (let ((res '())
+                   (tmp args))
+               (while (and tmp
+                           (not (memq (car tmp)
+                                      cl--lambda-list-keywords)))
+                 (push (pop tmp) res))
+               res))
+            (index -1)
+            (mutlist '())
+            (argvals
+             (mapcar
+	      (lambda (slot)
+	        (setq index (1+ index))
+	        (let* ((mutable (memq slot mutables))
+	               (get `(oclosure--get ,obj ,index ,(not (not mutable)))))
+	          (push mutable mutlist)
+		  (cond
+		   ((not (memq slot anames)) get)
+		   ((memq slot mnames) slot)
+		   (t
+		    `(if (eq ',absent ,slot)
+		         ,get
+		       ,slot)))))
+	      slots)))
+	 `(cl-defun ,cname (&cl-defs (',absent) ,obj ,@args)
+            ,doc
+            (declare (side-effect-free t))
+            (oclosure--copy ,obj ',(if (remq nil mutlist) (nreverse mutlist))
+                       ,@argvals))))
+     copiers)))
+
+(defmacro oclosure-define (name &optional docstring &rest slots)
+  (declare (doc-string 2) (indent 1))
+  (unless (stringp docstring)
+    (push docstring slots)
+    (setq docstring nil))
+  (let* ((options (when (consp name)
+                    (prog1 (copy-sequence (cdr name))
+                      (setq name (car name)))))
+         (get-opt (lambda (opt &optional all)
+                    (let ((val (assq opt options))
+                          tmp)
+                      (when val (setq options (delq val options)))
+                      (if (not all)
+                          (cdr val)
+                        (when val
+                          (setq val (list (cdr val)))
+                          (while (setq tmp (assq opt options))
+                            (push (cdr tmp) val)
+                            (setq options (delq tmp options)))
+                          (nreverse val))))))
+
+         (parent-names (or (or (funcall get-opt :parent)
+                               (funcall get-opt :include))
+                           '(oclosure-object)))
+         (copiers (funcall get-opt :copier 'all))
+
+         (parent-slots '())
+         (parents
+          (mapcar
+           (lambda (name)
+             (let* ((class (or (cl--find-class name)
+                               (error "Unknown parent: %S" name))))
+               (setq parent-slots
+                     (named-let merge
+                         ((slots-a parent-slots)
+                          (slots-b (cl--class-slots class)))
+                       (cond
+                        ((null slots-a) slots-b)
+                        ((null slots-b) slots-a)
+                        (t
+                         (let ((sa (car slots-a))
+                               (sb (car slots-b)))
+                           (unless (equal sa sb)
+                             (error "Slot %s of %s conflicts with slot %s of previous parent"
+                                    (cl--slot-descriptor-name sb)
+                                    name
+                                    (cl--slot-descriptor-name sa)))
+                           (cons sa (merge (cdr slots-a) (cdr slots-b))))))))
+               class))
+           parent-names))
+         (slotdescs
+          (append
+           parent-slots
+           (mapcar (lambda (field)
+                     (if (not (consp field))
+                         (cl--make-slot-descriptor field nil nil
+                                                   '((:read-only . t)))
+                       (let ((name (pop field))
+                             (type nil)
+                             (read-only t)
+                             (props '()))
+                         (while field
+                           (pcase (pop field)
+                             (:mutable (setq read-only (not (car field))))
+                             (:type (setq type (car field)))
+                             (p (message "Unknown property: %S" p)
+                                (push (cons p (car field)) props)))
+                           (setq field (cdr field)))
+                         (cl--make-slot-descriptor name nil type
+                                                   `((:read-only . ,read-only)
+                                                     ,@props)))))
+                   slots)))
+         (allparents (apply #'append (mapcar #'cl--class-allparents
+                                             parents)))
+         (class (oclosure--class-make name docstring slotdescs parents
+                                 (delete-dups
+                                  (cons name allparents))))
+         (it (make-hash-table :test #'eq)))
+    (setf (cl--class-index-table class) it)
+    `(progn
+       ,(when options (macroexp-warn-and-return
+                       (format "Ignored options: %S" options)
+                       nil))
+       (eval-and-compile
+         (oclosure--define ',class
+                      (lambda (oclosure)
+                        (let ((type (oclosure-type oclosure)))
+                          (when type
+                            (memq ',name (oclosure--class-allparents
+                                          (cl--find-class type))))))))
+       ,@(let ((i -1))
+           (mapcar (lambda (desc)
+                     (let* ((slot (cl--slot-descriptor-name desc))
+                            (mutable
+                             (not (alist-get :read-only
+                                             (cl--slot-descriptor-props desc))))
+                            ;; Always use a double hyphen: if users wants to
+                            ;; make it public, they can do so with an alias.
+                            (name (intern (format "%S--%S" name slot))))
+                       (cl-incf i)
+                       (when (gethash slot it)
+                         (error "Duplicate slot name: %S" slot))
+                       (setf (gethash slot it) i)
+                       (if (not mutable)
+                           `(defalias ',name
+                              ;; We use `oclosure--copy' instead of
+                              ;; `oclosure--accessor-copy' here to circumvent
+                              ;; bootstrapping problems.
+                              (oclosure--copy oclosure--accessor-prototype nil
+                                         ',name ',slot ,i))
+                         `(progn
+                            (defalias ',name
+                              (oclosure--accessor-copy
+                               oclosure--mut-getter-prototype
+                               ',name ',slot ,i))
+                            (defalias ',(gv-setter name)
+                              (oclosure--accessor-copy
+                               oclosure--mut-setter-prototype
+                               ',name ',slot ,i))))))
+                   slotdescs))
+       ,@(oclosure--defstruct-make-copiers
+          copiers slotdescs name))))
+
+(defun oclosure--define (class pred)
+  (let* ((name (cl--class-name class))
+         (predname (intern (format "oclosure--%s-p" name))))
+    (setf (cl--find-class name) class)
+    (defalias predname pred)
+    (put name 'cl-deftype-satisfies predname)))
+
+(defmacro oclosure--lambda (type bindings mutables args &rest body)
+  "Low level construction of an OClosure object.
+TYPE is expected to be a symbol that is (or will be) defined as an OClosure type.
+BINDINGS should list all the slots expected by this type, in the proper order.
+MUTABLE is a list of symbols indicating which of the BINDINGS
+should be mutable.
+No checking is performed,"
+  (declare (indent 3) (debug (sexp (&rest (sexp form)) sexp def-body)))
+  ;; FIXME: Fundamentally `oclosure-lambda' should be a special form.
+  ;; We define it here as a macro which expands to something that
+  ;; looks like "normal code" in order to avoid backward compatibility
+  ;; issues with third party macros that do "code walks" and would
+  ;; likely mishandle such a new special form (e.g. `generator.el').
+  ;; But don't be fooled: this macro is tightly bound to `cconv.el'.
+  (pcase-let*
+      ;; FIXME: Since we use the docstring internally to store the
+      ;; type we can't handle actual docstrings.  We could fix this by adding
+      ;; a docstring slot to OClosures.
+      ((`(,prebody . ,body) (macroexp-parse-body body))
+       (rovars (mapcar #'car bindings)))
+    (dolist (mutable mutables)
+      (setq rovars (delq mutable rovars)))
+    `(let ,(mapcar (lambda (bind)
+                     (if (cdr bind) bind
+                       ;; Bind to something that doesn't look
+                       ;; like a value to avoid the "Variable
+                       ;; ‘foo’ left uninitialized" warning.
+                       `(,(car bind) (progn nil))))
+                   (reverse bindings))
+       ;; FIXME: Make sure the slotbinds whose value is duplicable aren't
+       ;; just value/variable-propagated by the optimizer (tho I think our
+       ;; optimizer is too naive to be a problem currently).
+       (oclosure--fix-type
+        ;; This `oclosure--fix-type' + `ignore' call is used by the compiler (in
+        ;; `cconv.el') to detect and signal an error in case of
+        ;; store-conversion (i.e. if a variable/slot is mutated).
+        (ignore ,@rovars)
+        (lambda ,args
+          (:documentation ',type)
+          ,@prebody
+          ;; Add dummy code which accesses the field's vars to make sure
+          ;; they're captured in the closure.
+          (if t nil ,@rovars ,@(mapcar (lambda (m) `(setq ,m ,m)) mutables))
+          ,@body)))))
+
+(defmacro oclosure-lambda (type-and-slots args &rest body)
+  "Define anonymous OClosure function.
+TYPE-AND-SLOTS should be of the form (TYPE . SLOTS)
+where TYPE is an OClosure type name and
+SLOTS is a let-style list of bindings for the various slots of TYPE.
+ARGS and BODY are the same as for `lambda'."
+  (declare (indent 2) (debug ((sexp &rest (sexp form)) sexp def-body)))
+  ;; FIXME: Should `oclosure-define' distinguish "optional" from
+  ;; "mandatory" slots, and/or provide default values for slots missing
+  ;; from `fields'?
+  (pcase-let*
+      ((`(,type . ,fields) type-and-slots)
+       (class (cl--find-class type))
+       (slots (oclosure--class-slots class))
+       (mutables '())
+       (slotbinds (mapcar (lambda (slot)
+                            (let ((name (cl--slot-descriptor-name slot))
+                                  (props (cl--slot-descriptor-props slot)))
+                              (unless (alist-get :read-only props)
+                                (push name mutables))
+                              (list name)))
+                          slots))
+       (tempbinds (mapcar
+                   (lambda (field)
+                     (let* ((name (car field))
+                            (bind (assq name slotbinds)))
+                       (cond
+                        ((not bind)
+                         (error "Unknown slot: %S" name))
+                        ((cdr bind)
+                         (error "Duplicate slot: %S" name))
+                        (t
+                         (let ((temp (gensym "temp")))
+                           (setcdr bind (list temp))
+                           (cons temp (cdr field)))))))
+                   fields)))
+    ;; FIXME: Optimize temps away when they're provided in the right order?
+    `(let ,tempbinds
+       (oclosure--lambda ,type ,slotbinds ,mutables ,args ,@body))))
+
+(defun oclosure--fix-type (_ignore oclosure)
+  (if (byte-code-function-p oclosure)
+      ;; Actually, this should never happen since the `cconv.el' should have
+      ;; optimized away the call to this function.
+      oclosure
+    ;; For byte-coded functions, we store the type as a symbol in the docstring
+    ;; slot.  For interpreted functions, there's no specific docstring slot
+    ;; so `Ffunction' turns the symbol into a string.
+    ;; We thus have convert it back into a symbol (via `intern') and then
+    ;; stuff it into the environment part of the closure with a special
+    ;; marker so we can distinguish this entry from actual variables.
+    (cl-assert (eq 'closure (car-safe oclosure)))
+    (let ((typename (nth 3 oclosure))) ;; The "docstring".
+      (cl-assert (stringp typename))
+      (push (cons :type (intern typename))
+            (cadr oclosure))
+      oclosure)))
+
+(defun oclosure--copy (oclosure mutlist &rest args)
+  (if (byte-code-function-p oclosure)
+      (apply #'make-closure oclosure
+             (if (null mutlist)
+                 args
+               (mapcar (lambda (arg) (if (pop mutlist) (list arg) arg)) args)))
+    (cl-assert (eq 'closure (car-safe oclosure)))
+    (cl-assert (eq :type (caar (cadr oclosure))))
+    (let ((env (cadr oclosure)))
+      `(closure
+           (,(car env)
+            ,@(named-let loop ((env (cdr env)) (args args))
+                (when args
+                  (cons (cons (caar env) (car args))
+                        (loop (cdr env) (cdr args)))))
+            ,@(nthcdr (1+ (length args)) env))
+           ,@(nthcdr 2 oclosure)))))
+
+(defun oclosure--get (oclosure index mutable)
+  (if (byte-code-function-p oclosure)
+      (let* ((csts (aref oclosure 2))
+             (v (aref csts index)))
+        (if mutable (car v) v))
+    (cl-assert (eq 'closure (car-safe oclosure)))
+    (cl-assert (eq :type (caar (cadr oclosure))))
+    (cdr (nth (1+ index) (cadr oclosure)))))
+
+(defun oclosure--set (v oclosure index)
+  (if (byte-code-function-p oclosure)
+      (let* ((csts (aref oclosure 2))
+             (cell (aref csts index)))
+        (setcar cell v))
+    (cl-assert (eq 'closure (car-safe oclosure)))
+    (cl-assert (eq :type (caar (cadr oclosure))))
+    (setcdr (nth (1+ index) (cadr oclosure)) v)))
+
+(defun oclosure-type (oclosure)
+  "Return the type of OCLOSURE, or nil if the arg is not a OClosure."
+  (if (byte-code-function-p oclosure)
+      (let ((type (and (> (length oclosure) 4) (aref oclosure 4))))
+        (if (symbolp type) type))
+    (and (eq 'closure (car-safe oclosure))
+         (let* ((env (car-safe (cdr oclosure)))
+                (first-var (car-safe env)))
+           (and (eq :type (car-safe first-var))
+                (cdr first-var))))))
+
+(defconst oclosure--accessor-prototype
+  ;; Use `oclosure--lambda' to circumvent a bootstrapping problem:
+  ;; `oclosure-accessor' is not yet defined at this point but
+  ;; `oclosure--accessor-prototype' is needed when defining `oclosure-accessor'.
+  (oclosure--lambda oclosure-accessor ((type) (slot) (index)) nil
+    (oclosure) (oclosure--get oclosure index nil)))
+
+(oclosure-define accessor
+  "OClosure function to access a specific slot of an object."
+  type slot)
+
+(defun oclosure--accessor-cl-print (object stream)
+  (princ "#f(accessor " stream)
+  (prin1 (accessor--type object) stream)
+  (princ "." stream)
+  (prin1 (accessor--slot object) stream)
+  (princ ")" stream))
+
+(defun oclosure--accessor-docstring (f)
+  (format "Access slot \"%S\" of OBJ of type `%S'.
+
+\(fn OBJ)"
+          (accessor--slot f) (accessor--type f)))
+
+(oclosure-define (oclosure-accessor
+                (:parent accessor)
+                (:copier oclosure--accessor-copy (type slot index)))
+  "OClosure function to access a specific slot of an OClosure function."
+  index)
+
+(defconst oclosure--mut-getter-prototype
+  (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (oclosure)
+    (oclosure--get oclosure index t)))
+(defconst oclosure--mut-setter-prototype
+  ;; FIXME: The generated docstring is wrong.
+  (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (val oclosure)
+    (oclosure--set val oclosure index)))
+
+(provide 'oclosure)
+;;; oclosure.el ends here

lisp/emacs-lisp/syntax.el

@@ -487,7 +487,7 @@ These are valid when the buffer has no restriction.")
 
 (define-obsolete-function-alias 'syntax-ppss-after-change-function
   #'syntax-ppss-flush-cache "27.1")
-(defun syntax-ppss-flush-cache (beg &rest ignored)
+(defun syntax-ppss-flush-cache (beg &rest _)
   "Flush the cache of `syntax-ppss' starting at position BEG."
   ;; Set syntax-propertize to refontify anything past beg.
   (unless syntax-propertize--inhibit-flush

lisp/emacs-lisp/tabulated-list.el

@@ -378,7 +378,7 @@ Optional arg POS is a buffer position where to look for a fake header;
 defaults to `point-min'."
   (overlays-at (or pos (point-min))))
 
-(defun tabulated-list-revert (&rest ignored)
+(defun tabulated-list-revert (&rest _)
   "The `revert-buffer-function' for `tabulated-list-mode'.
 It runs `tabulated-list-revert-hook', then calls `tabulated-list-print'."
   (interactive)

lisp/files.el

@@ -2010,12 +2010,14 @@ otherwise a string <2> or <3> or ... is appended to get an unused name.
 Emacs treats buffers whose names begin with a space as internal buffers.
 To avoid confusion when visiting a file whose name begins with a space,
 this function prepends a \"|\" to the final result if necessary."
-  (let ((lastname (file-name-nondirectory filename)))
-    (if (string= lastname "")
-	(setq lastname filename))
-    (generate-new-buffer (if (string-prefix-p " " lastname)
-			     (concat "|" lastname)
-			   lastname))))
+  (let* ((lastname (file-name-nondirectory filename))
+	 (lastname (if (string= lastname "")
+	               filename lastname))
+	 (buf (generate-new-buffer (if (string-prefix-p " " lastname)
+			               (concat "|" lastname)
+			             lastname))))
+    (uniquify--create-file-buffer-advice buf filename)
+    buf))
 
 (defcustom automount-dir-prefix (purecopy "^/tmp_mnt/")
   "Regexp to match the automounter prefix in a directory name."
@@ -3786,7 +3788,7 @@ If these settings come from directory-local variables, then
 DIR-NAME is the name of the associated directory.  Otherwise it is nil."
   ;; Find those variables that we may want to save to
   ;; `safe-local-variable-values'.
-  (let (all-vars risky-vars unsafe-vars ignored)
+  (let (all-vars risky-vars unsafe-vars)
     (dolist (elt variables)
       (let ((var (car elt))
 	    (val (cdr elt)))

lisp/help.el

@@ -1944,10 +1944,8 @@ Most of this is done by `help-window-setup', which see."
 	  (princ msg)))))
 
 
-(defun help--docstring-quote (string)
-  "Return a doc string that represents STRING.
-The result, when formatted by `substitute-command-keys', should equal STRING."
-  (replace-regexp-in-string "['\\`‘’]" "\\\\=\\&" string))
+(define-obsolete-function-alias 'help--docstring-quote
+  #'docstring--quote "29.1")
 
 ;; The following functions used to be in help-fns.el, which is not preloaded.
 ;; But for various reasons, they are more widely needed, so they were
@@ -1987,24 +1985,7 @@ When SECTION is \\='usage or \\='doc, return only that part."
       (`usage usage)
       (`doc doc))))
 
-(defun help-add-fundoc-usage (docstring arglist)
-  "Add the usage info to DOCSTRING.
-If DOCSTRING already has a usage info, then just return it unchanged.
-The usage info is built from ARGLIST.  DOCSTRING can be nil.
-ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
-  (unless (stringp docstring) (setq docstring ""))
-  (if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring)
-          (eq arglist t))
-      docstring
-    (concat docstring
-	    (if (string-match "\n?\n\\'" docstring)
-		(if (< (- (match-end 0) (match-beginning 0)) 2) "\n" "")
-	      "\n\n")
-	    (if (stringp arglist)
-                (if (string-match "\\`[^ ]+\\(.*\\))\\'" arglist)
-                    (concat "(fn" (match-string 1 arglist) ")")
-                  (error "Unrecognized usage format"))
-	      (help--make-usage-docstring 'fn arglist)))))
+(defalias 'help-add-fundoc-usage #'docstring-add-fundoc-usage)
 
 (declare-function subr-native-lambda-list "data.c")
 
@@ -2061,32 +2042,13 @@ the same names as used in the original source code, when possible."
     "[Arg list not available until function definition is loaded.]")
    (t t)))
 
-(defun help--make-usage (function arglist)
-  (cons (if (symbolp function) function 'anonymous)
-	(mapcar (lambda (arg)
-		  (cond
-                   ;; Parameter name.
-                   ((symbolp arg)
-		    (let ((name (symbol-name arg)))
-		      (cond
-                       ((string-match "\\`&" name) arg)
-                       ((string-match "\\`_." name)
-                        (intern (upcase (substring name 1))))
-                       (t (intern (upcase name))))))
-                   ;; Parameter with a default value (from
-                   ;; cl-defgeneric etc).
-                   ((and (consp arg)
-                         (symbolp (car arg)))
-                    (cons (intern (upcase (symbol-name (car arg)))) (cdr arg)))
-                   ;; Something else.
-                   (t arg)))
-		arglist)))
+(define-obsolete-function-alias 'help--make-usage
+  #'docstring--make-usage "29.1")
 
 (define-obsolete-function-alias 'help-make-usage 'help--make-usage "25.1")
 
-(defun help--make-usage-docstring (fn arglist)
-  (let ((print-escape-newlines t))
-    (help--docstring-quote (format "%S" (help--make-usage fn arglist)))))
+(define-obsolete-function-alias 'help--make-usage-docstring
+  #'docstring--make-usage-docstring "29.1")
 
 
 
@@ -2132,7 +2094,10 @@ the suggested string to use instead.  See
                   confusables ", ")
        string))))
 
-(defun help-command-error-confusable-suggestions (data _context _signal)
+(defun help-command-error-confusable-suggestions (data context signal)
+  ;; Delegate most of the work to the original default value of
+  ;; `command-error-function' implemented in C.
+  (command-error-default-function data context signal)
   (pcase data
     (`(void-variable ,var)
      (let ((suggestions (help-uni-confusable-suggestions
@@ -2141,8 +2106,10 @@ the suggested string to use instead.  See
          (princ (concat "\n  " suggestions) t))))
     (_ nil)))
 
-(add-function :after command-error-function
-              #'help-command-error-confusable-suggestions)
+(when (eq command-error-function #'command-error-default-function)
+  ;; Override the default set in the C code.
+  (setq command-error-function
+        #'help-command-error-confusable-suggestions))
 
 (define-obsolete-function-alias 'help-for-help-internal #'help-for-help "28.1")
 

lisp/ido.el

@@ -3916,7 +3916,7 @@ If `ido-change-word-sub' cannot be found in WORD, return nil."
   "Return dotted pair (RES . 1)."
   (cons res 1))
 
-(defun ido-choose-completion-string (choice &rest ignored)
+(defun ido-choose-completion-string (choice &rest _)
   (when (ido-active)
     ;; Insert the completion into the buffer where completion was requested.
     (and ido-completion-buffer

lisp/international/mule-diag.el

@@ -812,7 +812,7 @@ but still contains full information about each coding system."
 
 (declare-function font-info "font.c" (name &optional frame))
 
-(defun describe-font-internal (font-info &optional ignored)
+(defun describe-font-internal (font-info &optional _ignored)
   "Print information about a font in FONT-INFO.
 The IGNORED argument is ignored."
   (print-list "name (opened by):" (aref font-info 0))

lisp/kmacro.el

@@ -362,9 +362,13 @@ information."
 
 ;;; Keyboard macro ring
 
+(oclosure-define kmacro
+  "Keyboard macro."
+  keys (counter :mutable t) format)
+
 (defvar kmacro-ring nil
   "The keyboard macro ring.
-Each element is a list (MACRO COUNTER FORMAT).  Actually, the head of
+Each element is a `kmacro'.  Actually, the head of
 the macro ring (when defining or executing) is not stored in the ring;
 instead it is available in the variables `last-kbd-macro', `kmacro-counter',
 and `kmacro-counter-format'.")
@@ -378,20 +382,23 @@ and `kmacro-counter-format'.")
 (defun kmacro-ring-head ()
   "Return pseudo head element in macro ring."
   (and last-kbd-macro
-       (list last-kbd-macro kmacro-counter kmacro-counter-format-start)))
+       (kmacro last-kbd-macro kmacro-counter kmacro-counter-format-start)))
 
 
 (defun kmacro-push-ring (&optional elt)
   "Push ELT or current macro onto `kmacro-ring'."
   (when (setq elt (or elt (kmacro-ring-head)))
+    (when (consp elt)
+      (message "Converting obsolete list form of kmacro: %S" elt)
+      (setq elt (apply #'kmacro elt)))
     (let ((history-delete-duplicates nil))
       (add-to-history 'kmacro-ring elt kmacro-ring-max))))
 
 
 (defun kmacro-split-ring-element (elt)
-  (setq last-kbd-macro (car elt)
-	kmacro-counter (nth 1 elt)
-	kmacro-counter-format-start (nth 2 elt)))
+  (setq last-kbd-macro (kmacro--keys elt)
+	kmacro-counter (kmacro--counter elt)
+	kmacro-counter-format-start (kmacro--format elt)))
 
 
 (defun kmacro-pop-ring1 (&optional raw)
@@ -481,21 +488,16 @@ Optional arg EMPTY is message to print if no macros are defined."
 
 
 ;;;###autoload
-(defun kmacro-exec-ring-item (item arg)
+(define-obsolete-function-alias 'kmacro-exec-ring-item #'funcall "29.1"
   "Execute item ITEM from the macro ring.
-ARG is the number of times to execute the item."
-  ;; Use counter and format specific to the macro on the ring!
-  (let ((kmacro-counter (nth 1 item))
-	(kmacro-counter-format-start (nth 2 item)))
-    (execute-kbd-macro (car item) arg #'kmacro-loop-setup-function)
-    (setcar (cdr item) kmacro-counter)))
+ARG is the number of times to execute the item.")
 
 
 (defun kmacro-call-ring-2nd (arg)
   "Execute second keyboard macro in macro ring."
   (interactive "P")
   (unless (kmacro-ring-empty-p)
-    (kmacro-exec-ring-item (car kmacro-ring) arg)))
+    (funcall (car kmacro-ring) arg)))
 
 
 (defun kmacro-call-ring-2nd-repeat (arg)
@@ -515,7 +517,7 @@ without repeating the prefix."
   "Display the second macro in the keyboard macro ring."
   (interactive)
   (unless (kmacro-ring-empty-p)
-    (kmacro-display (car (car kmacro-ring)) nil "2nd macro")))
+    (kmacro-display (kmacro--keys (car kmacro-ring)) nil "2nd macro")))
 
 
 (defun kmacro-cycle-ring-next (&optional _arg)
@@ -611,8 +613,7 @@ Use \\[kmacro-bind-to-key] to bind it to a key sequence."
     (let ((append (and arg (listp arg))))
       (unless append
 	(if last-kbd-macro
-	    (kmacro-push-ring
-	     (list last-kbd-macro kmacro-counter kmacro-counter-format-start)))
+	    (kmacro-push-ring))
 	(setq kmacro-counter (or (if arg (prefix-numeric-value arg))
 				 kmacro-initial-counter-value
 				 0)
@@ -748,9 +749,9 @@ With \\[universal-argument], call second macro in macro ring."
      (if kmacro-call-repeat-key
 	 (kmacro-call-macro arg no-repeat t)
        (kmacro-end-macro arg)))
-   ((and (eq this-command 'kmacro-view-macro)  ;; We are in repeat mode!
+   ((and (eq this-command #'kmacro-view-macro)  ;; We are in repeat mode!
 	 kmacro-view-last-item)
-    (kmacro-exec-ring-item (car kmacro-view-last-item) arg))
+    (funcall (car kmacro-view-last-item) arg))
    ((and arg (listp arg))
     (kmacro-call-ring-2nd 1))
    (t
@@ -811,42 +812,59 @@ If kbd macro currently being defined end it before activating it."
 ;; letters and digits, provided that we inhibit the keymap while
 ;; executing the macro later on (but that's controversial...)
 
+;;;###autoload
+(defun kmacro (keys &optional counter format)
+  "Create a `kmacro' for macro bound to symbol or key."
+  (oclosure-lambda (kmacro (keys (if (stringp keys) (key-parse keys) keys))
+                      (counter (or counter 0))
+                      (format (or format "%d")))
+      (&optional arg)
+    (interactive "p")
+    ;; Use counter and format specific to the macro on the ring!
+    (let ((kmacro-counter counter)
+	  (kmacro-counter-format-start format))
+      (execute-kbd-macro keys arg #'kmacro-loop-setup-function)
+      (setq counter kmacro-counter))))
+
 ;;;###autoload
 (defun kmacro-lambda-form (mac &optional counter format)
-  "Create lambda form for macro bound to symbol or key."
   ;; Apparently, there are two different ways this is called:
   ;; either `counter' and `format' are both provided and `mac' is a vector,
   ;; or only `mac' is provided, as a list (MAC COUNTER FORMAT).
   ;; The first is used from `insert-kbd-macro' and `edmacro-finish-edit',
   ;; while the second is used from within this file.
-  (let ((mac (if counter (list mac counter format) mac)))
-    ;; FIXME: This should be a "funcallable struct"!
-    (lambda (&optional arg)
-      "Keyboard macro."
-      ;; We put an "unused prompt" as a special marker so
-      ;; `kmacro-extract-lambda' can see it's "one of us".
-      (interactive "pkmacro")
-      (if (eq arg 'kmacro--extract-lambda)
-          (cons 'kmacro--extract-lambda mac)
-        (kmacro-exec-ring-item mac arg)))))
+  (declare (obsolete kmacro "29.1"))
+  (cond
+   ((kmacro-p mac) mac)
+   ((and (null counter) (consp mac)) (apply #'kmacro mac))
+   (t (kmacro mac counter format))))
 
 (defun kmacro-extract-lambda (mac)
   "Extract kmacro from a kmacro lambda form."
-  (let ((mac (cond
-              ((eq (car-safe mac) 'lambda)
-               (let ((e (assoc 'kmacro-exec-ring-item mac)))
-                 (car-safe (cdr-safe (car-safe (cdr-safe e))))))
-              ((and (functionp mac)
-                    (equal (interactive-form mac) '(interactive "pkmacro")))
-               (let ((r (funcall mac 'kmacro--extract-lambda)))
-                 (and (eq (car-safe r) 'kmacro--extract-lambda) (cdr r)))))))
-    (and (consp mac)
-         (= (length mac) 3)
-         (arrayp (car mac))
-         mac)))
+  (declare (obsolete nil "29.1"))
+  (when (kmacro-p mac)
+    (list (kmacro--keys mac)
+          (kmacro--counter mac)
+          (kmacro--format mac))))
 
-(defalias 'kmacro-p #'kmacro-extract-lambda
-  "Return non-nil if MAC is a kmacro keyboard macro.")
+(defun kmacro-p (x)
+  "Return non-nil if MAC is a kmacro keyboard macro."
+  (cl-typep x 'kmacro))
+
+(cl-defmethod cl-print-object ((object kmacro) stream)
+  (princ "#f(kmacro " stream)
+  (require 'macros)
+  (declare-function macros--insert-vector-macro "macros" (definition))
+  (let ((vecdef  (kmacro--keys     object))
+        (counter (kmacro--counter object))
+        (format  (kmacro--format  object)))
+    (prin1 (key-description vecdef) stream)
+    (unless (and (equal counter 0) (equal format "%d"))
+      (princ " " stream)
+      (prin1 counter stream)
+      (princ " " stream)
+      (prin1 format stream))
+    (princ ")" stream)))
 
 (defun kmacro-bind-to-key (_arg)
   "When not defining or executing a macro, offer to bind last macro to a key.
@@ -884,16 +902,15 @@ The ARG parameter is unused."
 		     (yes-or-no-p (format "%s runs command %S.  Bind anyway? "
 					  (format-kbd-macro key-seq)
 					  cmd))))
-	(define-key global-map key-seq
-	  (kmacro-lambda-form (kmacro-ring-head)))
+	(define-key global-map key-seq (kmacro-ring-head))
 	(message "Keyboard macro bound to %s" (format-kbd-macro key-seq))))))
 
 (defun kmacro-keyboard-macro-p (symbol)
   "Return non-nil if SYMBOL is the name of some sort of keyboard macro."
   (let ((f (symbol-function symbol)))
     (when f
-      (or (stringp f)
-	  (vectorp f)
+      (or (stringp f)                   ;FIXME: Really deprecated.
+	  (vectorp f)                   ;FIXME: Deprecated.
 	  (kmacro-p f)))))
 
 (defun kmacro-name-last-macro (symbol)
@@ -910,9 +927,7 @@ Such a \"function\" cannot be called from Lisp, but it is a valid editor command
 	      symbol))
   (if (string-equal symbol "")
       (error "No command name given"))
-  ;; FIXME: Use plain old `last-kbd-macro' for kmacros where it doesn't
-  ;; make a difference?
-  (fset symbol (kmacro-lambda-form (kmacro-ring-head)))
+  (fset symbol (kmacro-ring-head))
   ;; This used to be used to detect when a symbol corresponds to a kmacro.
   ;; Nowadays it's unused because we used `kmacro-p' instead to see if the
   ;; symbol's function definition matches that of a kmacro, which is more
@@ -953,7 +968,7 @@ The ARG parameter is unused."
   (interactive)
   (cond
    ((or (kmacro-ring-empty-p)
-	(not (eq last-command 'kmacro-view-macro)))
+	(not (eq last-command #'kmacro-view-macro)))
     (setq kmacro-view-last-item nil))
    ((null kmacro-view-last-item)
     (setq kmacro-view-last-item kmacro-ring
@@ -963,10 +978,10 @@ The ARG parameter is unused."
 	  kmacro-view-item-no (1+ kmacro-view-item-no)))
    (t
     (setq kmacro-view-last-item nil)))
-  (setq this-command 'kmacro-view-macro
+  (setq this-command #'kmacro-view-macro
 	last-command this-command) ;; in case we repeat
   (kmacro-display (if kmacro-view-last-item
-		      (car (car kmacro-view-last-item))
+		      (kmacro--keys (car kmacro-view-last-item))
 		    last-kbd-macro)
 		  nil
 		  (if kmacro-view-last-item
@@ -1113,7 +1128,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1',
 
     ;; Handle commands which reads additional input using read-char.
     (cond
-     ((and (eq this-command 'quoted-insert)
+     ((and (eq this-command #'quoted-insert)
 	   (not (eq kmacro-step-edit-action t)))
       ;; Find the actual end of this key sequence.
       ;; Must be able to backtrack in case we actually execute it.
@@ -1133,7 +1148,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1',
       (cond
        ((eq kmacro-step-edit-action t)  ;; Reentry for actual command @ end of prefix arg.
 	(cond
-	 ((eq this-command 'quoted-insert)
+	 ((eq this-command #'quoted-insert)
 	  (clear-this-command-keys) ;; recent-keys actually
 	  (let (unread-command-events)
 	    (quoted-insert (prefix-numeric-value current-prefix-arg))
@@ -1177,7 +1192,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1',
        ((eq act 'skip)
 	nil)
        ((eq act 'skip-keep)
-	(setq this-command 'ignore)
+	(setq this-command #'ignore)
 	t)
        ((eq act 'skip-rest)
 	(setq kmacro-step-edit-active 'ignore)
@@ -1227,7 +1242,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1',
       (if restore-index
 	  (setq executing-kbd-macro-index restore-index)))
      (t
-      (setq this-command 'ignore)))
+      (setq this-command #'ignore)))
     (setq kmacro-step-edit-key-index next-index)))
 
 (defun kmacro-step-edit-insert ()
@@ -1271,7 +1286,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1',
 	  (setq next-index kmacro-step-edit-key-index)
 	  t)
 	 (t nil))
-	(setq this-command 'ignore)
+	(setq this-command #'ignore)
       (setq this-command cmd)
       (if (memq this-command '(self-insert-command digit-argument))
 	  (setq last-command-event (aref keys (1- (length keys)))))
@@ -1284,7 +1299,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1',
   (when kmacro-step-edit-active
     (cond
      ((eq kmacro-step-edit-active 'ignore)
-      (setq this-command 'ignore))
+      (setq this-command #'ignore))
      ((eq kmacro-step-edit-active 'append-end)
       (if (= executing-kbd-macro-index (length executing-kbd-macro))
 	  (setq executing-kbd-macro (vconcat executing-kbd-macro [nil])

lisp/loadup.el

@@ -195,12 +195,10 @@
   (setq definition-prefixes new))
 
 (load "button")                  ;After loaddefs, because of define-minor-mode!
-(load "emacs-lisp/nadvice")
 (load "emacs-lisp/cl-preloaded")
+(load "emacs-lisp/oclosure")          ;Used by cl-generic and nadvice
 (load "obarray")        ;abbrev.el is implemented in terms of obarrays.
 (load "abbrev")         ;lisp-mode.el and simple.el use define-abbrev-table.
-(load "simple")
-
 (load "help")
 
 (load "jka-cmpr-hook")
@@ -250,6 +248,8 @@
 (let ((max-specpdl-size (max max-specpdl-size 1800)))
   ;; A particularly demanding file to load; 1600 does not seem to be enough.
   (load "emacs-lisp/cl-generic"))
+(load "simple")
+(load "emacs-lisp/nadvice")
 (load "minibuffer") ;Needs cl-generic (and define-minor-mode).
 (load "frame")
 (load "startup")

lisp/macros.el

@@ -46,6 +46,16 @@
                      " ")
           ?\]))
 
+(defun macro--string-to-vector (str)
+  "Convert an old-style string key sequence to the vector form."
+  (let ((vec (string-to-vector str)))
+    (unless (multibyte-string-p str)
+      (dotimes (i (length vec))
+	(let ((k (aref vec i)))
+	  (when (> k 127)
+	    (setf (aref vec i) (+ k ?\M-\C-@ -128))))))
+    vec))
+
 ;;;###autoload
 (defun insert-kbd-macro (macroname &optional keys)
   "Insert in buffer the definition of kbd macro MACRONAME, as Lisp code.
@@ -75,63 +85,25 @@ use this command, and then save the file."
       (insert "(fset '"))
     (prin1 macroname (current-buffer))
     (insert "\n   ")
-    (if (stringp definition)
-	(let ((beg (point)) end)
-	  (prin1 definition (current-buffer))
-	  (setq end (point-marker))
-	  (goto-char beg)
-	  (while (< (point) end)
-	    (let ((char (following-char)))
-	      (cond ((= char 0)
-		     (delete-region (point) (1+ (point)))
-		     (insert "\\C-@"))
-		    ((< char 27)
-		     (delete-region (point) (1+ (point)))
-		     (insert "\\C-" (+ 96 char)))
-		    ((= char ?\C-\\)
-		     (delete-region (point) (1+ (point)))
-		     (insert "\\C-\\\\"))
-		    ((< char 32)
-		     (delete-region (point) (1+ (point)))
-		     (insert "\\C-" (+ 64 char)))
-		    ((< char 127)
-		     (forward-char 1))
-		    ((= char 127)
-		     (delete-region (point) (1+ (point)))
-		     (insert "\\C-?"))
-		    ((= char 128)
-		     (delete-region (point) (1+ (point)))
-		     (insert "\\M-\\C-@"))
-		    ((= char (aref "\M-\C-\\" 0))
-		     (delete-region (point) (1+ (point)))
-		     (insert "\\M-\\C-\\\\"))
-		    ((< char 155)
-		     (delete-region (point) (1+ (point)))
-		     (insert "\\M-\\C-" (- char 32)))
-		    ((< char 160)
-		     (delete-region (point) (1+ (point)))
-		     (insert "\\M-\\C-" (- char 64)))
-		    ((= char (aref "\M-\\" 0))
-		     (delete-region (point) (1+ (point)))
-		     (insert "\\M-\\\\"))
-		    ((< char 255)
-		     (delete-region (point) (1+ (point)))
-		     (insert "\\M-" (- char 128)))
-		    ((= char 255)
-		     (delete-region (point) (1+ (point)))
-		     (insert "\\M-\\C-?"))))))
-      (if (vectorp definition)
-          (macros--insert-vector-macro definition)
-        (pcase (kmacro-extract-lambda definition)
-          (`(,vecdef ,counter ,format)
-           (insert "(kmacro-lambda-form ")
-           (macros--insert-vector-macro vecdef)
-           (insert " ")
-           (prin1 counter (current-buffer))
-           (insert " ")
-           (prin1 format (current-buffer))
-           (insert ")"))
-          (_ (prin1 definition (current-buffer))))))
+    (when (stringp definition)
+      (setq definition (macro--string-to-vector definition)))
+    (if (vectorp definition)
+        (setq definition (kmacro definition)))
+    (if (kmacro-p definition)
+        (let ((vecdef  (kmacro--keys     definition))
+              (counter (kmacro--counter definition))
+              (format  (kmacro--format  definition)))
+          (insert "(kmacro ")
+          (prin1 (key-description vecdef) (current-buffer))
+          ;; FIXME: Do we really want to store the counter?
+          (unless (and (equal counter 0) (equal format "%d"))
+            (insert " ")
+            (prin1 counter (current-buffer))
+            (insert " ")
+            (prin1 format (current-buffer)))
+          (insert ")"))
+      ;; FIXME: Shouldn't this signal an error?
+      (prin1 definition (current-buffer)))
     (insert ")\n")
     (if keys
         (let ((keys (or (where-is-internal (symbol-function macroname)

lisp/mail/sendmail.el

@@ -565,7 +565,7 @@ This also saves the value of `send-mail-function' via Customize."
 (defun sendmail-user-agent-compose (&optional to subject other-headers
 				    continue switch-function yank-action
 				    send-actions return-action
-				    &rest ignored)
+				    &rest _)
   (if switch-function
       (funcall switch-function "*mail*"))
   (let ((cc (cdr (assoc-string "cc" other-headers t)))

lisp/progmodes/fortran.el

@@ -960,7 +960,7 @@ With non-nil ARG, uncomments the region."
     (set-marker save-point nil)))
 
 ;; uncomment-region calls this with 3 args.
-(defun fortran-uncomment-region (start end &optional ignored)
+(defun fortran-uncomment-region (start end &optional _ignored)
   "Uncomment every line in the region."
   (fortran-comment-region start end t))
 

lisp/progmodes/prolog.el

@@ -1327,7 +1327,7 @@ With prefix argument ARG, restart the Prolog process if running before."
     (prolog-mode-variables)
     ))
 
-(defun prolog-inferior-guess-flavor (&optional ignored)
+(defun prolog-inferior-guess-flavor (&optional _ignored)
   (setq-local prolog-system
               (when (or (numberp prolog-system) (markerp prolog-system))
                 (save-excursion

lisp/progmodes/ruby-mode.el

@@ -840,7 +840,7 @@ The style of the comment is controlled by `ruby-encoding-magic-comment-style'."
     (back-to-indentation)
     (current-column)))
 
-(defun ruby-indent-line (&optional ignored)
+(defun ruby-indent-line (&optional _ignored)
   "Correct the indentation of the current Ruby line."
   (interactive)
   (ruby-indent-to (ruby-calculate-indent)))
@@ -1567,7 +1567,7 @@ With ARG, do it many times.  Negative ARG means move forward."
         ((error)))
       i))))
 
-(defun ruby-indent-exp (&optional ignored)
+(defun ruby-indent-exp (&optional _ignored)
   "Indent each line in the balanced expression following the point."
   (interactive "*P")
   (let ((here (point-marker)) start top column (nest t))

lisp/simple.el

@@ -29,6 +29,7 @@
 ;;; Code:
 
 (eval-when-compile (require 'cl-lib))
+(eval-when-compile (require 'subr-x))
 
 (declare-function widget-convert "wid-edit" (type &rest args))
 (declare-function shell-mode "shell" ())
@@ -2324,6 +2325,65 @@ maps."
   (with-suppressed-warnings ((interactive-only execute-extended-command))
     (execute-extended-command prefixarg command-name typed)))
 
+(cl-defgeneric function-docstring (function)
+  "Extract the raw docstring info from FUNCTION.
+FUNCTION is expected to be a function value rather than, say, a mere symbol."
+  (let ((docstring-p (lambda (doc) (or (stringp doc)
+                                  (fixnump doc) (fixnump (cdr-safe doc))))))
+    (pcase function
+      ((pred byte-code-function-p)
+       (when (> (length function) 4)
+         (let ((doc (aref function 4)))
+           (when (funcall docstring-p doc) doc))))
+      ((or (pred stringp) (pred vectorp)) "Keyboard macro.")
+      (`(keymap . ,_)
+       "Prefix command (definition is a keymap associating keystrokes with commands).")
+      ((or `(lambda ,_args . ,body) `(closure ,_env ,_args . ,body)
+           `(autoload ,_file . ,body))
+       (let ((doc (car body)))
+	 (when (and (funcall docstring-p doc)
+	            ;; Handle a doc reference--but these never come last
+	            ;; in the function body, so reject them if they are last.
+	            (cdr body))
+           doc)))
+      (_ (signal 'invalid-function (list function))))))
+
+(cl-defmethod function-docstring ((function accessor))
+  ;; FIXME: η-reduce!
+  (oclosure--accessor-docstring function))
+
+(cl-defgeneric interactive-form (cmd &optional original-name)
+  "Return the interactive form of CMD or nil if none.
+If CMD is not a command, the return value is nil.
+Value, if non-nil, is a list (interactive SPEC).
+ORIGINAL-NAME is used internally only."
+  (pcase cmd
+    ((pred symbolp)
+     (let ((fun (indirect-function cmd)))  ;Check cycles.
+       (when fun
+         (or (get cmd 'interactive-form)
+             (interactive-form (symbol-function cmd) (or original-name cmd))))))
+    ((pred byte-code-function-p)
+     (when (> (length cmd) 5)
+       (let ((form (aref cmd 5)))
+         (list 'interactive
+	       (if (vectorp form)
+	           ;; The vector form is the new form, where the first
+	           ;; element is the interactive spec, and the second
+	           ;; is the "command modes" info.
+	           (aref form 0)
+	         form)))))
+    ((pred autoloadp)
+     (interactive-form (autoload-do-load cmd original-name)))
+    ((or `(lambda ,_args . ,body)
+         `(closure ,_env ,_args . ,body))
+     (let ((spec (assq 'interactive body)))
+       (if (cddr spec)
+           ;; Drop the "command modes" info.
+           (list 'interactive (cadr spec))
+         spec)))
+    (_ (internal--interactive-form cmd))))
+
 (defun command-execute (cmd &optional record-flag keys special)
   ;; BEWARE: Called directly from the C code.
   "Execute CMD as an editor command.
@@ -6485,9 +6545,9 @@ is set to the buffer displayed in that window.")
         (with-current-buffer (window-buffer win)
           (run-hook-with-args 'pre-redisplay-functions win))))))
 
-(add-function :before pre-redisplay-function
-              #'redisplay--pre-redisplay-functions)
-
+(when (eq pre-redisplay-function #'ignore)
+  ;; Override the default set in the C code.
+  (setq pre-redisplay-function #'redisplay--pre-redisplay-functions))
 
 (defvar-local mark-ring nil
   "The list of former marks of the current buffer, most recent first.")

lisp/subr.el

@@ -6510,6 +6510,55 @@ sentence (see Info node `(elisp) Documentation Tips')."
     (error "Unable to fill string containing newline: %S" string))
   (internal--fill-string-single-line (apply #'format string objects)))
 
+(defun docstring--quote (string)
+  "Return a doc string that represents STRING.
+The result, when formatted by `substitute-command-keys', should equal STRING."
+  (replace-regexp-in-string "['\\`‘’]" "\\\\=\\&" string))
+
+(defun docstring-add-fundoc-usage (docstring arglist)
+  "Add the usage info to DOCSTRING.
+If DOCSTRING already has a usage info, then just return it unchanged.
+The usage info is built from ARGLIST.  DOCSTRING can be nil.
+ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
+  (unless (stringp docstring) (setq docstring ""))
+  (if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring)
+          (eq arglist t))
+      docstring
+    (concat docstring
+	    (if (string-match "\n?\n\\'" docstring)
+		(if (< (- (match-end 0) (match-beginning 0)) 2) "\n" "")
+	      "\n\n")
+	    (if (stringp arglist)
+                (if (string-match "\\`[^ ]+\\(.*\\))\\'" arglist)
+                    (concat "(fn" (match-string 1 arglist) ")")
+                  (error "Unrecognized usage format"))
+	      (docstring--make-usage-docstring 'fn arglist)))))
+
+(defun docstring--make-usage (function arglist)
+  (cons (if (symbolp function) function 'anonymous)
+	(mapcar (lambda (arg)
+		  (cond
+                   ;; Parameter name.
+                   ((symbolp arg)
+		    (let ((name (symbol-name arg)))
+		      (cond
+                       ((string-match "\\`&" name) arg)
+                       ((string-match "\\`_." name)
+                        (intern (upcase (substring name 1))))
+                       (t (intern (upcase name))))))
+                   ;; Parameter with a default value (from
+                   ;; cl-defgeneric etc).
+                   ((and (consp arg)
+                         (symbolp (car arg)))
+                    (cons (intern (upcase (symbol-name (car arg)))) (cdr arg)))
+                   ;; Something else.
+                   (t arg)))
+		arglist)))
+
+(defun docstring--make-usage-docstring (fn arglist)
+  (let ((print-escape-newlines t))
+    (docstring--quote (format "%S" (docstring--make-usage fn arglist)))))
+
 (defun json-available-p ()
   "Return non-nil if Emacs has libjansson support."
   (and (fboundp 'json-serialize)

lisp/uniquify.el

@@ -476,34 +476,32 @@ For use on `kill-buffer-hook'."
 ;; rename-buffer and create-file-buffer.  (Setting find-file-hook isn't
 ;; sufficient.)
 
-(advice-add 'rename-buffer :around #'uniquify--rename-buffer-advice)
-(defun uniquify--rename-buffer-advice (rb-fun newname &optional unique &rest args)
+;; (advice-add 'rename-buffer :around #'uniquify--rename-buffer-advice)
+(defun uniquify--rename-buffer-advice (newname &optional unique)
+  ;; BEWARE: This is called directly from `buffer.c'!
   "Uniquify buffer names with parts of directory name."
-  (let ((retval (apply rb-fun newname unique args)))
   (uniquify-maybe-rerationalize-w/o-cb)
-    (if (null unique)
+  (if (null unique)
       ;; Mark this buffer so it won't be renamed by uniquify.
       (setq uniquify-managed nil)
     (when uniquify-buffer-name-style
       ;; Rerationalize w.r.t the new name.
       (uniquify-rationalize-file-buffer-names
-         newname
+       newname
        (uniquify-buffer-file-name (current-buffer))
-       (current-buffer))
-        (setq retval (buffer-name (current-buffer)))))
-    retval))
+       (current-buffer)))))
 
 
-(advice-add 'create-file-buffer :around #'uniquify--create-file-buffer-advice)
-(defun uniquify--create-file-buffer-advice (cfb-fun filename &rest args)
+;; (advice-add 'create-file-buffer :around #'uniquify--create-file-buffer-advice)
+(defun uniquify--create-file-buffer-advice (buf filename)
+  ;; BEWARE: This is called directly from `files.el'!
   "Uniquify buffer names with parts of directory name."
-  (let ((retval (apply cfb-fun filename args)))
-  (if uniquify-buffer-name-style
-        (let ((filename (expand-file-name (directory-file-name filename))))
-	(uniquify-rationalize-file-buffer-names
-	 (file-name-nondirectory filename)
-           (file-name-directory filename) retval)))
-    retval))
+  (when uniquify-buffer-name-style
+    (let ((filename (expand-file-name (directory-file-name filename))))
+      (uniquify-rationalize-file-buffer-names
+       (file-name-nondirectory filename)
+       (file-name-directory filename)
+       buf))))
 
 (defun uniquify-unload-function ()
   "Unload the uniquify library."
@@ -513,8 +511,6 @@ For use on `kill-buffer-hook'."
 	(set-buffer buf)
 	(when uniquify-managed
 	  (push (cons buf (uniquify-item-base (car uniquify-managed))) buffers)))
-      (advice-remove 'rename-buffer #'uniquify--rename-buffer-advice)
-      (advice-remove 'create-file-buffer #'uniquify--create-file-buffer-advice)
       (dolist (buf buffers)
 	(set-buffer (car buf))
 	(rename-buffer (cdr buf) t))))

lisp/url/url.el

@@ -291,7 +291,7 @@ how long to wait for a response before giving up."
 (declare-function mm-display-part "mm-decode"
 		  (handle &optional no-default force))
 
-(defun url-mm-callback (&rest ignored)
+(defun url-mm-callback (&rest _)
   (let ((handle (mm-dissect-buffer t)))
     (url-mark-buffer-as-dead (current-buffer))
     (with-current-buffer

lisp/xwidget.el

@@ -1168,7 +1168,7 @@ Press \\<xwidget-webkit-isearch-mode-map>\\[xwidget-webkit-isearch-exit] to exit
     (xwidget-webkit-goto-history xwidget-webkit-history--session id))
   (xwidget-webkit-history-reload))
 
-(defun xwidget-webkit-history-reload (&rest ignored)
+(defun xwidget-webkit-history-reload (&rest _ignored)
   "Reload the current history buffer."
   (interactive)
   (setq tabulated-list-entries nil)

src/buffer.c

@@ -1552,7 +1552,7 @@ This does not change the name of the visited file (if any).  */)
 
   /* Catch redisplay's attention.  Unless we do this, the mode lines for
      any windows displaying current_buffer will stay unchanged.  */
-  update_mode_lines = 11;
+  bset_update_mode_line (current_buffer);
 
   XSETBUFFER (buf, current_buffer);
   Fsetcar (Frassq (buf, Vbuffer_alist), newname);
@@ -1562,6 +1562,9 @@ This does not change the name of the visited file (if any).  */)
 
   run_buffer_list_update_hook (current_buffer);
 
+  call2 (intern ("uniquify--rename-buffer-advice"),
+         BVAR (current_buffer, name), unique);
+
   /* Refetch since that last call may have done GC.  */
   return BVAR (current_buffer, name);
 }

src/callint.c

@@ -315,7 +315,7 @@ invoke it (via an `interactive' spec that contains, for instance, an
   Lisp_Object up_event = Qnil;
 
   /* Set SPECS to the interactive form, or barf if not interactive.  */
-  Lisp_Object form = Finteractive_form (function);
+  Lisp_Object form = call1 (Qinteractive_form, function);
   if (! CONSP (form))
     wrong_type_argument (Qcommandp, function);
   Lisp_Object specs = Fcar (XCDR (form));

src/data.c

@@ -945,29 +945,12 @@ DEFUN ("native-comp-unit-set-file", Fnative_comp_unit_set_file,
 
 #endif
 
-DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0,
-       doc: /* Return the interactive form of CMD or nil if none.
+DEFUN ("internal--interactive-form", Finternal__interactive_form, Sinternal__interactive_form, 1, 1, 0,
+       doc: /* Return the interactive form of FUN or nil if none.
 If CMD is not a command, the return value is nil.
 Value, if non-nil, is a list (interactive SPEC).  */)
-  (Lisp_Object cmd)
+  (Lisp_Object fun)
 {
-  Lisp_Object fun = indirect_function (cmd); /* Check cycles.  */
-
-  if (NILP (fun))
-    return Qnil;
-
-  /* Use an `interactive-form' property if present, analogous to the
-     function-documentation property.  */
-  fun = cmd;
-  while (SYMBOLP (fun))
-    {
-      Lisp_Object tmp = Fget (fun, Qinteractive_form);
-      if (!NILP (tmp))
-	return tmp;
-      else
-	fun = Fsymbol_function (fun);
-    }
-
   if (SUBRP (fun))
     {
       if (SUBR_NATIVE_COMPILEDP (fun) && !NILP (XSUBR (fun)->native_intspec))
@@ -979,21 +962,6 @@ Value, if non-nil, is a list (interactive SPEC).  */)
 		      (*spec != '(') ? build_string (spec) :
 		      Fcar (Fread_from_string (build_string (spec), Qnil, Qnil)));
     }
-  else if (COMPILEDP (fun))
-    {
-      if (PVSIZE (fun) > COMPILED_INTERACTIVE)
-	{
-	  Lisp_Object form = AREF (fun, COMPILED_INTERACTIVE);
-	  if (VECTORP (form))
-	    /* The vector form is the new form, where the first
-	       element is the interactive spec, and the second is the
-	       command modes. */
-	    return list2 (Qinteractive, AREF (form, 0));
-	  else
-	    /* Old form -- just the interactive spec. */
-	    return list2 (Qinteractive, form);
-	}
-    }
 #ifdef HAVE_MODULES
   else if (MODULE_FUNCTIONP (fun))
     {
@@ -1003,24 +971,6 @@ Value, if non-nil, is a list (interactive SPEC).  */)
         return form;
     }
 #endif
-  else if (AUTOLOADP (fun))
-    return Finteractive_form (Fautoload_do_load (fun, cmd, Qnil));
-  else if (CONSP (fun))
-    {
-      Lisp_Object funcar = XCAR (fun);
-      if (EQ (funcar, Qclosure)
-	  || EQ (funcar, Qlambda))
-	{
-	  Lisp_Object form = Fcdr (XCDR (fun));
-	  if (EQ (funcar, Qclosure))
-	    form = Fcdr (form);
-	  Lisp_Object spec = Fassq (Qinteractive, form);
-	  if (NILP (Fcdr (Fcdr (spec))))
-	    return spec;
-	  else
-	    return list2 (Qinteractive, Fcar (Fcdr (spec)));
-	}
-    }
   return Qnil;
 }
 
@@ -4078,7 +4028,7 @@ syms_of_data (void)
   DEFSYM (Qbyte_code_function_p, "byte-code-function-p");
 
   defsubr (&Sindirect_variable);
-  defsubr (&Sinteractive_form);
+  defsubr (&Sinternal__interactive_form);
   defsubr (&Scommand_modes);
   defsubr (&Seq);
   defsubr (&Snull);

src/doc.c

@@ -327,6 +327,8 @@ string is passed through `substitute-command-keys'.  */)
     xsignal1 (Qvoid_function, function);
   if (CONSP (fun) && EQ (XCAR (fun), Qmacro))
     fun = XCDR (fun);
+  /* FIXME: The code for subrs and module functions should be
+     in `function-docstring`.  */
 #ifdef HAVE_NATIVE_COMP
   if (!NILP (Fsubr_native_elisp_p (fun)))
     doc = native_function_doc (fun);
@@ -338,56 +340,8 @@ string is passed through `substitute-command-keys'.  */)
   else if (MODULE_FUNCTIONP (fun))
     doc = module_function_documentation (XMODULE_FUNCTION (fun));
 #endif
-  else if (COMPILEDP (fun))
-    {
-      if (PVSIZE (fun) <= COMPILED_DOC_STRING)
-	return Qnil;
-      else
-	{
-	  Lisp_Object tem = AREF (fun, COMPILED_DOC_STRING);
-	  if (STRINGP (tem))
-	    doc = tem;
-	  else if (FIXNATP (tem) || CONSP (tem))
-	    doc = tem;
-	  else
-	    return Qnil;
-	}
-    }
-  else if (STRINGP (fun) || VECTORP (fun))
-    {
-      return build_string ("Keyboard macro.");
-    }
-  else if (CONSP (fun))
-    {
-      Lisp_Object funcar = XCAR (fun);
-      if (!SYMBOLP (funcar))
-	xsignal1 (Qinvalid_function, fun);
-      else if (EQ (funcar, Qkeymap))
-	return build_string ("Prefix command (definition is a keymap associating keystrokes with commands).");
-      else if (EQ (funcar, Qlambda)
-	       || (EQ (funcar, Qclosure) && (fun = XCDR (fun), 1))
-	       || EQ (funcar, Qautoload))
-	{
-	  Lisp_Object tem1 = Fcdr (Fcdr (fun));
-	  Lisp_Object tem = Fcar (tem1);
-	  if (STRINGP (tem))
-	    doc = tem;
-	  /* Handle a doc reference--but these never come last
-	     in the function body, so reject them if they are last.  */
-	  else if ((FIXNATP (tem) || (CONSP (tem) && FIXNUMP (XCDR (tem))))
-		   && !NILP (XCDR (tem1)))
-	    doc = tem;
-	  else
-	    return Qnil;
-	}
-      else
-	goto oops;
-    }
   else
-    {
-    oops:
-      xsignal1 (Qinvalid_function, fun);
-    }
+    doc = call1 (intern ("function-docstring"), fun);
 
   /* If DOC is 0, it's typically because of a dumped file missing
      from the DOC file (bug in src/Makefile.in).  */
@@ -511,11 +465,19 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset)
     {
       /* This bytecode object must have a slot for the
 	 docstring, since we've found a docstring for it.  */
-      if (PVSIZE (fun) > COMPILED_DOC_STRING)
+      if (PVSIZE (fun) > COMPILED_DOC_STRING
+	  /* Don't overwrite a non-docstring value placed there,
+           * such as is used in FCRs.  */
+	  && (FIXNUMP (AREF (fun, COMPILED_DOC_STRING))
+	      || STRINGP (AREF (fun, COMPILED_DOC_STRING))
+	      || CONSP (AREF (fun, COMPILED_DOC_STRING))))
 	ASET (fun, COMPILED_DOC_STRING, make_fixnum (offset));
       else
 	{
-	  AUTO_STRING (format, "No docstring slot for %s");
+	  AUTO_STRING (format,
+	               (PVSIZE (fun) > COMPILED_DOC_STRING
+	                ? "Docstring slot busy for %s"
+	                : "No docstring slot for %s"));
 	  CALLN (Fmessage, format,
 		 (SYMBOLP (obj)
 		  ? SYMBOL_NAME (obj)

src/eval.c

@@ -574,6 +574,10 @@ usage: (function ARG)  */)
 	{ /* Handle the special (:documentation <form>) to build the docstring
 	     dynamically.  */
 	  Lisp_Object docstring = eval_sub (Fcar (XCDR (tmp)));
+	  if (SYMBOLP (docstring) && !NILP (docstring))
+	    /* Hack for FCRs: Allow the docstring to be a symbol
+             * (the FCR's type).  */
+	    docstring = Fsymbol_name (docstring);
 	  CHECK_STRING (docstring);
 	  cdr = Fcons (XCAR (cdr), Fcons (docstring, XCDR (XCDR (cdr))));
 	}
@@ -2167,8 +2171,7 @@ then strings and vectors are not accepted.  */)
   (Lisp_Object function, Lisp_Object for_call_interactively)
 {
   register Lisp_Object fun;
-  register Lisp_Object funcar;
-  Lisp_Object if_prop = Qnil;
+  bool genfun = false;
 
   fun = function;
 
@@ -2176,6 +2179,71 @@ then strings and vectors are not accepted.  */)
   if (NILP (fun))
     return Qnil;
 
+  /* Emacs primitives are interactive if their DEFUN specifies an
+     interactive spec.  */
+  if (SUBRP (fun))
+    {
+      if (XSUBR (fun)->intspec)
+        return Qt;
+    }
+  /* Bytecode objects are interactive if they are long enough to
+     have an element whose index is COMPILED_INTERACTIVE, which is
+     where the interactive spec is stored.  */
+  else if (COMPILEDP (fun))
+    {
+      if (PVSIZE (fun) > COMPILED_INTERACTIVE)
+        return Qt;
+      else if (PVSIZE (fun) > COMPILED_DOC_STRING)
+        genfun = true;
+    }
+
+#ifdef HAVE_MODULES
+  /* Module functions are interactive if their `interactive_form'
+     field is non-nil. */
+  else if (MODULE_FUNCTIONP (fun))
+    {
+      if (!NILP (module_function_interactive_form (XMODULE_FUNCTION (fun))))
+        return Qt;
+    }
+#endif
+
+  /* Strings and vectors are keyboard macros.  */
+  else if (STRINGP (fun) || VECTORP (fun))
+    return (NILP (for_call_interactively) ? Qt : Qnil);
+
+  /* Lists may represent commands.  */
+  else if (!CONSP (fun))
+    return Qnil;
+  else
+    {
+      Lisp_Object funcar = XCAR (fun);
+      if (EQ (funcar, Qautoload))
+        {
+          if (!NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))))
+            return Qt;
+        }
+      else
+        {
+          Lisp_Object body = CDR_SAFE (XCDR (fun));
+          if (EQ (funcar, Qclosure))
+            body = CDR_SAFE (body);
+          else if (!EQ (funcar, Qlambda))
+	    return Qnil;
+	  if (!NILP (Fassq (Qinteractive, body)))
+	    return Qt;
+	  else
+	    {
+	      body = CAR_SAFE (body);
+	      if (!NILP (CDR_SAFE (body))
+	          && (STRINGP (body) || FIXNUMP (body) ||
+	              FIXNUMP (CDR_SAFE (body))))
+	        genfun = true;
+	    }
+	}
+    }
+
+  /* By now, if it's not a function we already returned nil.  */
+
   /* Check an `interactive-form' property if present, analogous to the
      function-documentation property.  */
   fun = function;
@@ -2183,45 +2251,20 @@ then strings and vectors are not accepted.  */)
     {
       Lisp_Object tmp = Fget (fun, Qinteractive_form);
       if (!NILP (tmp))
-	if_prop = Qt;
+	return Qt;
       fun = Fsymbol_function (fun);
     }
 
-  /* Emacs primitives are interactive if their DEFUN specifies an
-     interactive spec.  */
-  if (SUBRP (fun))
-    return XSUBR (fun)->intspec ? Qt : if_prop;
-
-  /* Bytecode objects are interactive if they are long enough to
-     have an element whose index is COMPILED_INTERACTIVE, which is
-     where the interactive spec is stored.  */
-  else if (COMPILEDP (fun))
-    return (PVSIZE (fun) > COMPILED_INTERACTIVE ? Qt : if_prop);
-
-#ifdef HAVE_MODULES
-  /* Module functions are interactive if their `interactive_form'
-     field is non-nil. */
-  else if (MODULE_FUNCTIONP (fun))
-    return NILP (module_function_interactive_form (XMODULE_FUNCTION (fun)))
-             ? if_prop
-             : Qt;
-#endif
-
-  /* Strings and vectors are keyboard macros.  */
-  if (STRINGP (fun) || VECTORP (fun))
-    return (NILP (for_call_interactively) ? Qt : Qnil);
-
-  /* Lists may represent commands.  */
-  if (!CONSP (fun))
-    return Qnil;
-  funcar = XCAR (fun);
-  if (EQ (funcar, Qclosure))
-    return (!NILP (Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun)))))
-	    ? Qt : if_prop);
-  else if (EQ (funcar, Qlambda))
-    return !NILP (Fassq (Qinteractive, Fcdr (XCDR (fun)))) ? Qt : if_prop;
-  else if (EQ (funcar, Qautoload))
-    return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))) ? Qt : if_prop;
+  /* If there's no immdiate interactive form but there's a docstring,
+     then delegate to the generic-function in case it's an FCR with
+     a type-specific interactive-form.  */
+  if (genfun
+      /* Avoid burping during bootstrap.  */
+      && !NILP (Fsymbol_function (Qinteractive_form)))
+    {
+      Lisp_Object iform = call1 (Qinteractive_form, fun);
+      return NILP (iform) ? Qnil : Qt;
+    }
   else
     return Qnil;
 }

test/lisp/emacs-lisp/cconv-tests.el

@@ -23,6 +23,7 @@
 
 (require 'ert)
 (require 'cl-lib)
+(require 'generator)
 
 (ert-deftest cconv-tests-lambda-:documentation ()
   "Docstring for lambda can be specified with :documentation."
@@ -83,9 +84,6 @@
   (iter-yield 'cl-iter-defun-result))
 (ert-deftest cconv-tests-cl-iter-defun-:documentation ()
   "Docstring for cl-iter-defun can be specified with :documentation."
-  ;; FIXME: See Bug#28557.
-  :tags '(:unstable)
-  :expected-result :failed
   (should (string= (documentation 'cconv-tests-cl-iter-defun)
                    "cl-iter-defun documentation"))
   (should (eq (iter-next (cconv-tests-cl-iter-defun))
@@ -96,17 +94,12 @@
   (iter-yield 'iter-defun-result))
 (ert-deftest cconv-tests-iter-defun-:documentation ()
   "Docstring for iter-defun can be specified with :documentation."
-  ;; FIXME: See Bug#28557.
-  :tags '(:unstable)
-  :expected-result :failed
   (should (string= (documentation 'cconv-tests-iter-defun)
                    "iter-defun documentation"))
   (should (eq (iter-next (cconv-tests-iter-defun)) 'iter-defun-result)))
 
 (ert-deftest cconv-tests-iter-lambda-:documentation ()
   "Docstring for iter-lambda can be specified with :documentation."
-  ;; FIXME: See Bug#28557.
-  :expected-result :failed
   (let ((iter-fun
          (iter-lambda ()
            (:documentation (concat "iter-lambda" " documentation"))
@@ -116,13 +109,11 @@
 
 (ert-deftest cconv-tests-cl-function-:documentation ()
   "Docstring for cl-function can be specified with :documentation."
-  ;; FIXME: See Bug#28557.
-  :expected-result :failed
   (let ((fun (cl-function (lambda (&key arg)
                             (:documentation (concat "cl-function"
                                                     " documentation"))
                             (list arg 'cl-function-result)))))
-    (should (string= (documentation fun) "cl-function documentation"))
+    (should (string-match "\\`cl-function documentation$" (documentation fun)))
     (should (equal (funcall fun :arg t) '(t cl-function-result)))))
 
 (ert-deftest cconv-tests-function-:documentation ()
@@ -142,8 +133,6 @@
   (+ 1 n))
 (ert-deftest cconv-tests-cl-defgeneric-:documentation ()
   "Docstring for cl-defgeneric can be specified with :documentation."
-  ;; FIXME: See Bug#28557.
-  :expected-result :failed
   (let ((descr (describe-function 'cconv-tests-cl-defgeneric)))
     (set-text-properties 0 (length descr) nil descr)
     (should (string-match-p "cl-defgeneric documentation" descr))

test/lisp/emacs-lisp/nadvice-tests.el

@@ -153,13 +153,13 @@ function being an around advice."
 
 (ert-deftest advice-test-call-interactively ()
   "Check interaction between advice on call-interactively and called-interactively-p."
-  (defun sm-test7.4 () (interactive) (cons 1 (called-interactively-p)))
-  (let ((old (symbol-function 'call-interactively)))
+  (let ((sm-test7.4 (lambda () (interactive) (cons 1 (called-interactively-p))))
+        (old (symbol-function 'call-interactively)))
     (unwind-protect
         (progn
           (advice-add 'call-interactively :before #'ignore)
-          (should (equal (sm-test7.4) '(1 . nil)))
-          (should (equal (call-interactively 'sm-test7.4) '(1 . t))))
+          (should (equal (funcall sm-test7.4) '(1 . nil)))
+          (should (equal (call-interactively sm-test7.4) '(1 . t))))
       (advice-remove 'call-interactively #'ignore)
       (should (eq (symbol-function 'call-interactively) old)))))
 
@@ -204,6 +204,17 @@ function being an around advice."
     (remove-function (var sm-test10) sm-advice)
     (should (equal (funcall sm-test10 5) 15))))
 
+(ert-deftest advice-test-print ()
+  (let ((x (list 'cdr)))
+    (add-function :after (car x) 'car)
+    (should (equal (cl-prin1-to-string (car x))
+                   "#f(advice car :after cdr)"))
+    (add-function :before (car x) 'first)
+    (should (equal (cl-prin1-to-string (car x))
+                   "#f(advice first :before #f(advice car :after cdr))"))
+    (should (equal (cl-prin1-to-string (cadar advice--where-alist))
+                   "#f(advice nil :around nil)"))))
+
 ;; Local Variables:
 ;; no-byte-compile: t
 ;; End:

test/lisp/emacs-lisp/oclosure-tests.el

@@ -0,0 +1,124 @@
+;;; oclosure-tests.e; --- Tests for Open Closures  -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'oclosure)
+(require 'cl-lib)
+
+(oclosure-define (oclosure-test
+                (:copier oclosure-test-copy)
+                (:copier oclosure-test-copy1 (fst)))
+  "Simple OClosure."
+  fst snd name)
+
+(cl-defmethod oclosure-test-gen ((_x compiled-function)) "#<bytecode>")
+
+(cl-defmethod oclosure-test-gen ((_x cons)) "#<cons>")
+
+(cl-defmethod oclosure-test-gen ((_x oclosure-object))
+  (format "#<oclosure:%s>" (cl-call-next-method)))
+
+(cl-defmethod oclosure-test-gen ((_x oclosure-test))
+  (format "#<oclosure-test:%s>" (cl-call-next-method)))
+
+(ert-deftest oclosure-tests ()
+  (let* ((i 42)
+         (ocl1 (oclosure-lambda (oclosure-test (fst 1) (snd 2) (name "hi"))
+                   ()
+                 (list fst snd i)))
+         (ocl2 (oclosure-lambda (oclosure-test (name (cl-incf i)) (fst (cl-incf i)))
+                   ()
+                 (list fst snd 152 i))))
+    (should (equal (list (oclosure-test--fst ocl1)
+                         (oclosure-test--snd ocl1)
+                         (oclosure-test--name ocl1))
+                   '(1 2 "hi")))
+    (should (equal (list (oclosure-test--fst ocl2)
+                         (oclosure-test--snd ocl2)
+                         (oclosure-test--name ocl2))
+                   '(44 nil 43)))
+    (should (equal (funcall ocl1) '(1 2 44)))
+    (should (equal (funcall ocl2) '(44 nil 152 44)))
+    (should (equal (funcall (oclosure-test-copy ocl1 :fst 7)) '(7 2 44)))
+    (should (equal (funcall (oclosure-test-copy1 ocl1 9)) '(9 2 44)))
+    (should (cl-typep ocl1 'oclosure-test))
+    (should (cl-typep ocl1 'oclosure-object))
+    (should (member (oclosure-test-gen ocl1)
+                    '("#<oclosure-test:#<oclosure:#<cons>>>"
+                      "#<oclosure-test:#<oclosure:#<bytecode>>>")))
+    ))
+
+(ert-deftest oclosure-tests--limits ()
+  (should
+   (condition-case err
+       (let ((lexical-binding t)
+             (byte-compile-debug t))
+         (byte-compile '(lambda ()
+                          (let ((inc-where nil))
+                            (oclosure-lambda (advice (where 'foo)) ()
+                              (setq inc-where (lambda () (setq where (1+ where))))
+                              where))))
+         nil)
+     (error
+      (and (eq 'error (car err))
+           (string-match "where.*mutated" (cadr err))))))
+  (should
+   (condition-case err
+       (progn (macroexpand '(oclosure-define oclosure--foo a a))
+              nil)
+     (error
+      (and (eq 'error (car err))
+           (string-match "Duplicate slot name: a$" (cadr err))))))
+  (should
+   (condition-case err
+       (progn (macroexpand '(oclosure-define (oclosure--foo (:parent advice)) where))
+              nil)
+     (error
+      (and (eq 'error (car err))
+           (string-match "Duplicate slot name: where$" (cadr err))))))
+  (should
+   (condition-case err
+       (progn (macroexpand '(oclosure-lambda (advice (where 1) (where 2)) () where))
+              nil)
+     (error
+      (and (eq 'error (car err))
+           (string-match "Duplicate slot: where$" (cadr err)))))))
+
+(oclosure-define (oclosure-test-mut
+                (:parent oclosure-test)
+                (:copier oclosure-test-mut-copy))
+  "Simple OClosure with a mutable field."
+  (mut :mutable t))
+
+(ert-deftest oclosure-test--mutate ()
+  (let* ((f (oclosure-lambda (oclosure-test-mut (fst 0) (mut 3))
+                (x)
+              (+ x fst mut)))
+         (f2 (oclosure-test-mut-copy f :fst 50)))
+    (should (equal (oclosure-test-mut--mut f) 3))
+    (should (equal (funcall f 5) 8))
+    (should (equal (funcall f2 5) 58))
+    (cl-incf (oclosure-test-mut--mut f) 7)
+    (should (equal (oclosure-test-mut--mut f) 10))
+    (should (equal (funcall f 5) 15))
+    (should (equal (funcall f2 15) 68))))
+
+;;; oclosure-tests.el ends here.

test/lisp/kmacro-tests.el

@@ -583,8 +583,10 @@ This is a regression test for: Bug#3412, Bug#11817."
     ;; Check the bound key and run it and verify correct counter
     ;; and format.
     (should (equal (string-to-vector "\C-cxi")
-                   (car (kmacro-extract-lambda
-                         (key-binding "\C-x\C-kA")))))
+                   (car (with-suppressed-warnings
+                            ((obsolete kmacro-extract-lambda))
+                          (kmacro-extract-lambda
+                           (key-binding "\C-x\C-kA"))))))
     (kmacro-tests-should-insert "<5>"
       (funcall (key-binding "\C-x\C-kA")))))
 
@@ -608,7 +610,7 @@ This is a regression test for: Bug#3412, Bug#11817."
   (dotimes (i 2)
     (kmacro-tests-define-macro (make-vector (1+ i) (+ ?a i)))
     (kmacro-name-last-macro 'kmacro-tests-symbol-for-test)
-    (should (fboundp 'kmacro-tests-symbol-for-test)))
+    (should (commandp 'kmacro-tests-symbol-for-test)))
 
   ;; Now run the function bound to the symbol. Result should be the
   ;; second macro.
@@ -825,6 +827,15 @@ This is a regression for item 7 in Bug#24991."
                                 :macro-result "x")
     (kmacro-tests-simulate-command '(beginning-of-line))))
 
+(ert-deftest kmacro-tests--cl-print ()
+  (should (equal (cl-prin1-to-string
+                  (kmacro [?a ?b backspace backspace]))
+                 "#f(kmacro \"a b <backspace> <backspace>\")"))
+  (should (equal (cl-prin1-to-string
+                  (with-suppressed-warnings ((obsolete kmacro-lambda-form))
+                    (kmacro-lambda-form [?a ?b backspace backspace] 1 "%d")))
+                 "#f(kmacro \"a b <backspace> <backspace>\" 1 \"%d\")")))
+
 (cl-defun kmacro-tests-run-step-edit
     (macro &key events sequences result macro-result)
   "Set up and run a test of `kmacro-step-edit-macro'.

test/lisp/progmodes/elisp-mode-tests.el

@@ -449,12 +449,15 @@ to (xref-elisp-test-descr-to-target xref)."
   ;; dispatching code.
   )
 
-(cl-defgeneric xref-elisp-generic-co-located-default (arg1 arg2)
+(cl-defgeneric xref-elisp-generic-co-located-default (_arg1 _arg2)
   "Doc string generic co-located-default."
   "co-located default")
 
 (cl-defmethod xref-elisp-generic-co-located-default ((this xref-elisp-root-type) arg2)
   "Doc string generic co-located-default xref-elisp-root-type."
+  ;; The test needs the above line to contain "this" and "arg2"
+  ;; without underscores, so we silence the warning with `ignore'.
+  (ignore this arg2)
   "non-default for co-located-default")
 
 (cl-defgeneric xref-elisp-generic-separate-default (arg1 arg2)