scratch/fcr 2554d02 1/2: lisp/emacs-lisp/fcr.el: Make it available to cl-generic

[Stefan Monnier]

branch: scratch/fcr
commit 2554d029f67ce2011e3261d0a9a945eb2202ef53
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    lisp/emacs-lisp/fcr.el: Make it available to cl-generic
    
    * lisp/loadup.el: Load `fcr`.
    
    * lisp/emacs-lisp/fcr.el: Don't use `cl-lib` at runtime.
    (fcr--copy): Use `named-let` instead of `cl-mapcar`.
    (fcr--struct-tag, fcr--struct-specializers, fcr--struct-generalizer)
    (cl-generic-generalizers): Move cl-generic support to cl-generic.
    
    * lisp/emacs-lisp/cl-generic.el (cl--generic-fcr-tag)
    (cl-generic--fcr-specializers, cl-generic--fcr-generalizer)
    (cl-generic-generalizers): Move FCR support from `fcr.el`.
---
 lisp/dired-aux.el             |  2 +-
 lisp/emacs-lisp/cl-generic.el | 27 +++++++++++++++++++++++++++
 lisp/emacs-lisp/fcr.el        | 36 +++++-------------------------------
 lisp/loadup.el                |  1 +
 lisp/xwidget.el               |  2 +-
 5 files changed, 35 insertions(+), 33 deletions(-)

diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index 5301a3a..56c7e19 100644
--- a/lisp/dired-aux.el
+++ b/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."
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 9de47e4..ad2bdc0 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -1293,6 +1293,33 @@ Used internally for the (major-mode MODE) context 
specializers."
                     (progn (cl-assert (null modes)) mode)
                   `(derived-mode ,mode . ,modes))))
 
+;;; Dispatch on FCR type
+
+(defun cl--generic-fcr-tag (name &rest _)
+  `(fcr-type ,name))
+
+(defun cl-generic--fcr-specializers (tag &rest _)
+  (and (symbolp tag)
+       (let ((class (cl--find-class tag)))
+         (when (cl-typep class 'fcr--class)
+           (cl--generic-class-parents class)))))
+
+(cl-generic-define-generalizer cl-generic--fcr-generalizer
+  50 #'cl--generic-fcr-tag
+  #'cl-generic--fcr-specializers)
+
+(cl-defmethod cl-generic-generalizers :extra "fcr-struct" (type)
+  "Support for dispatch on types defined by `fcr-defstruct'."
+  (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 'fcr--class)
+            (list cl-generic--fcr-generalizer))))
+   (cl-call-next-method)))
+
 ;;; Support for unloading.
 
 (cl-defmethod loadhist-unload-element ((x (head cl-defmethod)))
diff --git a/lisp/emacs-lisp/fcr.el b/lisp/emacs-lisp/fcr.el
index 028d289..51fc240 100644
--- a/lisp/emacs-lisp/fcr.el
+++ b/lisp/emacs-lisp/fcr.el
@@ -41,7 +41,7 @@
 
 ;;; Code:
 
-(require 'cl-lib)
+(eval-when-compile (require 'cl-lib))
 (eval-when-compile (require 'subr-x))   ;For `named-let'.
 
 (cl-defstruct (fcr--class
@@ -251,7 +251,10 @@
     (let ((env (cadr fcr)))
       `(closure
            (,(car env)
-            ,@(cl-mapcar (lambda (b v) (cons (car b) v)) (cdr env) args)
+            ,@(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 fcr)))))
 
@@ -272,34 +275,5 @@
          (eq fcr--type-sym (caar (cadr fcr)))
          (cdar (cadr fcr)))))
 
-;;; Support for cl-generic
-
-(defun fcr--struct-tag (name &rest _)
-  `(fcr-type ,name))
-
-(defun fcr--struct-specializers (tag &rest _)
-  (and (symbolp tag)
-       (let ((class (cl--find-class tag)))
-         (when (cl-typep class 'fcr--class)
-           (cl--generic-class-parents class)))))
-
-(cl-generic-define-generalizer fcr--struct-generalizer
-  50 #'fcr--struct-tag
-  #'fcr--struct-specializers)
-
-(cl-defmethod cl-generic-generalizers :extra "fcr-struct" (type)
-  "Support for dispatch on types defined by `fcr-defstruct'."
-  (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 'fcr--class)
-            (list fcr--struct-generalizer))))
-   (cl-call-next-method)))
-
-
-
 (provide 'fcr)
 ;;; fcr.el ends here
diff --git a/lisp/loadup.el b/lisp/loadup.el
index 71d6a50..dec26ed 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -247,6 +247,7 @@
 (load "language/cham")
 
 (load "indent")
+(load "emacs-lisp/fcr")          ;Used by cl-generic
 (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"))
diff --git a/lisp/xwidget.el b/lisp/xwidget.el
index ce9839e..64a1b1b 100644
--- a/lisp/xwidget.el
+++ b/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)