scratch/oclosure 9aa72cce6b: (oclosure-define): Add `:predicate`

[Stefan Monnier]

branch: scratch/oclosure
commit 9aa72cce6b041d57ef0a02c63130e8fb5662ad49
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    (oclosure-define): Add `:predicate`
    
    * lisp/files.el (save-some-buffers): Use the defined predicate instead
    of `cl-typep` so we don't need to load `cl-lib`.
    
    * lisp/emacs-lisp/oclosure.el (oclosure--merge-classes):
    Improve error message.
    (oclosure-define): Add `:predicate` and fix `:mixin` handling.
    (oclosure--define): Add support for `:predicate`.
    (oclosure-lambda): Improve error message.
    (save-some-buffers-function): Use `:predicate`.
---
 lisp/emacs-lisp/oclosure.el | 20 +++++++++++++-------
 lisp/files.el               |  6 ++----
 2 files changed, 15 insertions(+), 11 deletions(-)

diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
index 9e0024a6c7..c53182fccd 100644
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -214,7 +214,9 @@
 
 (defun oclosure--merge-classes (names)
   (if (null (cdr names))
-      (cl--find-class (or (car names) 'oclosure))
+      (let ((name (or (car names) 'oclosure)))
+        (or (cl--find-class name)
+            (error "Unknown class: %S" name)))
     (let* ((total-slots '())
            (name (vconcat names))
            (pinned 0)
@@ -299,18 +301,19 @@
                             (push (cdr tmp) val)
                             (setq options (delq tmp options)))
                           (nreverse val))))))
-
+         (predicate (car (funcall get-opt :predicate)))
          (parent-names (or (funcall get-opt :parent)
                            (funcall get-opt :include)))
          (copiers (funcall get-opt :copier 'all))
-         (mixin (funcall get-opt :mixin)))
+         (mixin (car (funcall get-opt :mixin))))
     `(progn
        ,(when options (macroexp-warn-and-return
                        (format "Ignored options: %S" options)
                        nil))
        (eval-and-compile
          (oclosure--define ',name ,docstring ',parent-names ',slots
-                           :mixin ',mixin))
+                           ,@(when mixin `(:mixin ',mixin))
+                           ,@(when predicate `(:predicate ',predicate))))
        (oclosure--define-functions ,name ,copiers))))
 
 (defun oclosure--build-class (name docstring parent-names slots mixin)
@@ -401,7 +404,8 @@
                    (when type
                      (memq name (oclosure--class-allparents
                                  (cl--find-class type)))))))
-         (predname (intern (format "%s--internal-p" name))))
+         (predname (or (plist-get props :predicate)
+                       (intern (format "%s--internal-p" name)))))
     (setf (cl--find-class name) class)
     (dolist (slot (oclosure--class-slots class))
       (put (cl--slot-descriptor-name slot) 'slot-name t))
@@ -495,7 +499,8 @@ ARGS and BODY are the same as for `lambda'."
                    `(oclosure--anonymous-define
                      ',(oclosure--anonymous-name types) ',types)))
        (type (eval type-exp t))
-       (class (cl--find-class type))
+       (class (or (cl--find-class type)
+                  (error "Unknown class: %S" type)))
        (slots (oclosure--class-slots class))
        (mutables '())
        (slotbinds (mapcar (lambda (slot)
@@ -676,7 +681,8 @@ ARGS and BODY are the same as for `lambda'."
 
 ;; Ideally, this should be in `files.el', but that file is loaded
 ;; before `oclosure.el'.
-(oclosure-define save-some-buffers-function)
+(oclosure-define (save-some-buffers-function
+                  (:predicate save-some-buffers-function--p)))
 
 
 (provide 'oclosure)
diff --git a/lisp/files.el b/lisp/files.el
index a7f3c1c086..593925f138 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -5845,12 +5845,10 @@ change the additional actions you can take on files."
   (interactive "P")
   (unless pred
     (setq pred save-some-buffers-default-predicate))
-  ;; Can't be required at top-level for bootstrap reasons.
-  (eval-when-compile (require 'cl-lib))
   ;; Allow `pred' to be a function that returns a predicate
   ;; with lexical bindings in its original environment (bug#46374).
-  (when (or (and (symbolp pred) (get pred 'save-some-buffers-function))
-            (cl-typep pred 'save-some-buffers-function))
+  (when (or (and (symbolp pred) (get pred 'save-some-buffers-function)
+                 (save-some-buffers-function--p pred)))
     (let ((pred-fun (and (functionp pred) (funcall pred))))
       (when (functionp pred-fun)
         (setq pred pred-fun))))