scratch/oclosure cd2a5037fa 1/2: oclosure.el: Add anonymous classes

[Stefan Monnier]

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

    oclosure.el: Add anonymous classes
    
    Allow listing several types in `oclosure-lambda` and build an
    anonymous class for it on the fly.
    
    * lisp/emacs-lisp/oclosure.el (oclosure--lambda): Change `type` arg to
    take an expression rather than a value.
    (oclosure--anonymous-name, oclosure--anonymous-define): New functions.
    (oclosure-lambda): Allow multiple type symbols and generate an
    anonymous class on the fly in this case.
    
    * lisp/files.el (file-relative-name): Avoid errors if used early during
    the preload.
    
    * src/eval.c (Fcommandp): Fix the detection of docstring in CONSP case.
    
    * test/lisp/emacs-lisp/oclosure-tests.el (oclosure-test-anonymous):
    New test.
---
 lisp/emacs-lisp/oclosure.el            | 32 ++++++++++++++++++++++++--------
 lisp/files.el                          |  3 ++-
 src/eval.c                             |  8 ++++----
 test/lisp/emacs-lisp/oclosure-tests.el | 25 +++++++++++++++++++++----
 4 files changed, 51 insertions(+), 17 deletions(-)

diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
index 1bb136326e..1efaf207bb 100644
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -115,7 +115,6 @@
 ;; - `oclosure-(cl-)defun', `oclosure-(cl-)defsubst', `oclosure-define-inline'?
 ;; - Use accessor in cl-defstruct.
 ;; - Add pcase patterns for OClosures.
-;; - anonymous OClosure types.
 ;; - copiers for mixins
 ;; - class-allocated slots?
 ;; - code-allocated slots?
@@ -412,7 +411,7 @@
 
 (defmacro oclosure--lambda (type bindings mutables args &rest body)
   "Low level construction of an OClosure object.
-TYPE should be be a symbol that is (or will be) defined as an OClosure type.
+TYPE should be be an form returning an OClosure type (a symbol)
 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.
@@ -425,9 +424,6 @@ No checking is performed,"
   ;; 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)
@@ -448,13 +444,22 @@ No checking is performed,"
         ;; store-conversion (i.e. if a variable/slot is mutated).
         (ignore ,@rovars)
         (lambda ,args
-          (:documentation ',type)
+          (: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)))))
 
+(defun oclosure--anonymous-name (names)
+  (intern (format "%S" (vconcat names))))
+
+(defun oclosure--anonymous-define (name names)
+  (unless (cl--find-class name)
+    (setf (cl--find-class name)
+          (oclosure--merge-classes names)))
+  name)
+
 (defmacro oclosure-lambda (type-and-slots args &rest body)
   "Define anonymous OClosure function.
 TYPE-AND-SLOTS should be of the form (TYPE . SLOTS)
@@ -467,6 +472,15 @@ ARGS and BODY are the same as for `lambda'."
   ;; from `fields'?
   (pcase-let*
       ((`(,type . ,fields) type-and-slots)
+       (types (named-let loop ((types (list type)))
+                (if (listp (car fields))
+                    (nreverse types)
+                  (loop (cons (pop fields) types)))))
+       (type-exp (if (null (cdr types))
+                     `',(car types)
+                   `(oclosure--anonymous-define
+                     ',(oclosure--anonymous-name types) ',types)))
+       (type (eval type-exp t))
        (class (cl--find-class type))
        (slots (oclosure--class-slots class))
        (mutables '())
@@ -481,6 +495,7 @@ ARGS and BODY are the same as for `lambda'."
                      (let* ((name (car field))
                             (bind (assq name slotbinds)))
                        (cond
+                        ;; FIXME: Should we also warn about missing slots?
                         ((not bind)
                          (error "Unknown slot: %S" name))
                         ((cdr bind)
@@ -492,7 +507,7 @@ ARGS and BODY are the same as for `lambda'."
                    fields)))
     ;; FIXME: Optimize temps away when they're provided in the right order?
     `(let ,tempbinds
-       (oclosure--lambda ,type ,slotbinds ,mutables ,args ,@body))))
+       (oclosure--lambda ,type-exp ,slotbinds ,mutables ,args ,@body))))
 
 (defun oclosure--fix-type (_ignore oclosure)
   (if (byte-code-function-p oclosure)
@@ -563,7 +578,7 @@ ARGS and BODY are the same as for `lambda'."
   ;; 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--lambda 'oclosure-accessor ((type) (slot) (index)) nil
     (oclosure) (oclosure--get oclosure index nil)))
 
 (oclosure-define accessor
@@ -635,5 +650,6 @@ ARGS and BODY are the same as for `lambda'."
   (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (val oclosure)
     (oclosure--set val oclosure
                    (oclosure--mixin-slot-index oclosure slot))))
+
 (provide 'oclosure)
 ;;; oclosure.el ends here
diff --git a/lisp/files.el b/lisp/files.el
index 94ac213a99..c4587e9c20 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -5343,7 +5343,8 @@ on a DOS/Windows machine, it returns FILENAME in expanded 
form."
     (let ((fremote (file-remote-p filename))
          (dremote (file-remote-p directory))
          (fold-case (or (file-name-case-insensitive-p filename)
-                        read-file-name-completion-ignore-case)))
+                        (bound-and-true-p
+                         read-file-name-completion-ignore-case))))
       (if ;; Conditions for separate trees
          (or
           ;; Test for different filesystems on DOS/Windows
diff --git a/src/eval.c b/src/eval.c
index 29243b1d54..8eccba9a11 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -2233,10 +2233,10 @@ then strings and vectors are not accepted.  */)
            return Qt;
          else
            {
-             body = CAR_SAFE (body);
+             Lisp_Object first = CAR_SAFE (body);
              if (!NILP (CDR_SAFE (body))
-                 && (STRINGP (body) || FIXNUMP (body) ||
-                     FIXNUMP (CDR_SAFE (body))))
+                 && (STRINGP (first) || FIXNUMP (first) ||
+                     FIXNUMP (CDR_SAFE (first))))
                genfun = true;
            }
        }
@@ -2255,7 +2255,7 @@ then strings and vectors are not accepted.  */)
       fun = Fsymbol_function (fun);
     }
 
-  /* If there's no immdiate interactive form but there's a docstring,
+  /* If there's no immediate 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
diff --git a/test/lisp/emacs-lisp/oclosure-tests.el 
b/test/lisp/emacs-lisp/oclosure-tests.el
index 3f433d8c87..243921a734 100644
--- a/test/lisp/emacs-lisp/oclosure-tests.el
+++ b/test/lisp/emacs-lisp/oclosure-tests.el
@@ -39,7 +39,7 @@
 (cl-defmethod oclosure-test-gen ((_x oclosure-test))
   (format "#<oclosure-test:%s>" (cl-call-next-method)))
 
-(ert-deftest oclosure-tests ()
+(ert-deftest oclosure-test ()
   (let* ((i 42)
          (ocl1 (oclosure-lambda (oclosure-test (fst 1) (snd 2) (name "hi"))
                    ()
@@ -66,7 +66,7 @@
                       "#<oclosure-test:#<oclosure:#<bytecode>>>")))
     ))
 
-(ert-deftest oclosure-tests--limits ()
+(ert-deftest oclosure-test-limits ()
   (should
    (condition-case err
        (let ((lexical-binding t)
@@ -109,7 +109,7 @@
   "Simple OClosure with a mutable field."
   (mut :mutable t))
 
-(ert-deftest oclosure-test--mutate ()
+(ert-deftest oclosure-test-mutate ()
   (let* ((f (oclosure-lambda (oclosure-test-mut (fst 0) (mut 3))
                 (x)
               (+ x fst mut)))
@@ -155,7 +155,7 @@
     (should (equal 'cm3 (oclosure-test-mixin2--cm ocl3)))
     (should (equal 'd3 (oclosure-test-mixin3--d ocl3)))))
 
-(ert-deftest oclosure-tests-slot-value ()
+(ert-deftest oclosure-test-slot-value ()
   (require 'eieio)
   (let ((ocl1 (oclosure-lambda (oclosure-test-mixin1 (a 'a1) (b 'b1) (bm 'bm1))
                   (x) (list a b x)))
@@ -183,4 +183,21 @@
     (should (equal 'c3 (slot-value ocl3 'c)))
     ))
 
+(ert-deftest oclosure-test-anonymous ()
+  (let ((ocl1 (oclosure-lambda (oclosure-test
+                                oclosure-test-mixin1
+                                (fst 'fst) (snd 'snd)
+                                (a 'a))
+                  (x)
+                (list x fst))))
+
+    (should (equal (oclosure-test-mixin1--a ocl1)
+                   'a))
+    (should (equal (oclosure-test--snd ocl1)
+                   'snd))
+    (should (equal (funcall ocl1 'x) '(x fst)))
+    (should (cl-typep ocl1 'oclosure-test))
+    (should (cl-typep ocl1 'oclosure-test-mixin1))
+    (should (cl-typep ocl1 '(and oclosure-test oclosure-test-mixin1)))))
+
 ;;; oclosure-tests.el ends here.