scratch/oclosure f44ee8cd53 17/25: oclosure.el (accessor): New type

[Stefan Monnier]

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

    oclosure.el (accessor): New type
    
    * lisp/emacs-lisp/oclosure.el (accessor): New (OClosure) type.
    (oclosure-define): Mark the accessor functions
    as being of type `accessor`.
    (oclosure--accessor-cl-print, oclosure--accessor-docstring): New functions.
    
    * src/doc.c (store_function_docstring): Improve message and fix check.
    * lisp/simple.el (function-docstring) <accessor>: New method.
    * lisp/emacs-lisp/cl-print.el (cl-print-object) <accessor>: New method.
---
 lisp/emacs-lisp/cl-print.el |  4 ++++
 lisp/emacs-lisp/crm.el      |  2 +-
 lisp/emacs-lisp/oclosure.el | 37 +++++++++++++++++++++++++++++++------
 lisp/simple.el              |  4 ++++
 src/doc.c                   |  6 +++++-
 5 files changed, 45 insertions(+), 8 deletions(-)

diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index 047d198859..6521c3bf7c 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -229,6 +229,10 @@ into a button whose action shows the function's 
disassembly.")
   ;; FIXME: η-reduce!
   (advice--cl-print-object object stream))
 
+(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)
            (> cl-print--depth print-level))
diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el
index 59cbc0e50d..9ac4747f54 100644
--- a/lisp/emacs-lisp/crm.el
+++ b/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
diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
index 65785a7ed8..956dff7ffa 100644
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -38,6 +38,8 @@
 ;;   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 slot accessors instead of storing them
+;;   in the accessor itself?
 
 ;;; Code:
 
@@ -55,6 +57,11 @@
 ;;   store-conversion is indispensable, so if we want to avoid store-conversion
 ;;   we'd have to disallow such capture.
 
+;; FIXME:
+;; - Snarf-documentation leaves bogus fixnums in place in`create-file-buffer'.
+;; - `oclosure-cl-defun', `oclosure-cl-defsubst', `oclosure-defsubst', 
`oclosure-define-inline'?
+;; - Use accessor in cl-defstruct
+
 (eval-when-compile (require 'cl-lib))
 (eval-when-compile (require 'subr-x))   ;For `named-let'.
 
@@ -186,12 +193,13 @@
                        (when (gethash slot it)
                          (error "Duplicate slot name: %S" slot))
                        (setf (gethash slot it) i)
-                       ;; Always use a double hyphen: if the user wants to
-                       ;; make it public, it can do so with an alias.
-                       `(defun ,(intern (format "%S--%S" name slot)) (oclosure)
-                          ,(format "Return slot `%S' of OClosure, of type 
`%S'."
-                                   slot name)
-                          (oclosure-get oclosure ,i))))
+                       ;; Always use a double hyphen: if users wants to
+                       ;; make it public, they can do so with an alias.
+                       ;; FIXME: Use a copier!
+                       `(defalias ',(intern (format "%S--%S" name slot))
+                          (oclosure-lambda accessor ((type ',name) (slot 
',slot))
+                                      (oclosure)
+                            (oclosure-get oclosure ,i)))))
                    slotdescs))
        ,@(oclosure--defstruct-make-copiers copiers slots name))))
 
@@ -315,5 +323,22 @@
            (and (eq :type (car-safe first-var))
                 (cdr first-var))))))
 
+(oclosure-define accessor
+  "OClosure to access the field 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)))
+
 (provide 'oclosure)
 ;;; oclosure.el ends here
diff --git a/lisp/simple.el b/lisp/simple.el
index 9227ee5caa..65234732cb 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -2348,6 +2348,10 @@ FUNCTION is expected to be a function value rather than, 
say, a mere symbol."
            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.
diff --git a/src/doc.c b/src/doc.c
index 336ca0b852..5c8f059288 100644
--- a/src/doc.c
+++ b/src/doc.c
@@ -469,11 +469,15 @@ store_function_docstring (Lisp_Object obj, EMACS_INT 
offset)
          /* 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)