scratch/fcr 780957c: FCR: Hybrids between functions and defstructs

[Stefan Monnier]

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

    FCR: Hybrids between functions and defstructs
    
    * lisp/emacs-lisp/fcr.el: New file.
    * test/lisp/emacs-lisp/fcr-tests.el: New file.
    * src/eval.c (Ffunction): Allow :documentation to return a symbol.
    * lisp/emacs-lisp/cconv.el (cconv--convert-function): Tweak ordering of
    captured variables.
---
 lisp/emacs-lisp/cconv.el          |  14 +-
 lisp/emacs-lisp/fcr.el            | 305 ++++++++++++++++++++++++++++++++++++++
 src/eval.c                        |   4 +
 test/lisp/emacs-lisp/fcr-tests.el |  75 ++++++++++
 4 files changed, 393 insertions(+), 5 deletions(-)

diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index 7cec91b..d1c7bc0 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/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 FCR: `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
@@ -450,6 +451,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)))
 
diff --git a/lisp/emacs-lisp/fcr.el b/lisp/emacs-lisp/fcr.el
new file mode 100644
index 0000000..028d289
--- /dev/null
+++ b/lisp/emacs-lisp/fcr.el
@@ -0,0 +1,305 @@
+;;; fcr.el --- FunCallableRecords       -*- 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 FunCallableRecord 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 FCRs might be useful:
+;; - nadvice.el
+;; - iterators (generator.el), thunks (thunk.el), streams (stream.el).
+;; - kmacros (for cl-print and for `kmacro-extract-lambda')
+;; - PEG rules: they're currently just functions, but they should carry
+;;   their original (macro-expanded) definition (and should be printed
+;;   differently from functions)!
+;; - cl-generic: turn `cl--generic-isnot-nnm-p' into a mere type test
+;;   (by putting the no-next-methods into their own class).
+;; - 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.
+
+;;; Code:
+
+(require 'cl-lib)
+(eval-when-compile (require 'subr-x))   ;For `named-let'.
+
+(cl-defstruct (fcr--class
+               (:constructor nil)
+               (:constructor fcr--class-make ( name docstring slots parents
+                                               allparents))
+               (:include cl--class)
+               (:copier nil))
+  "Metaclass for FunCallableRecord classes."
+  (allparents nil :read-only t :type (list-of symbol)))
+
+(setf (cl--find-class 'fcr-object)
+      (fcr--class-make 'fcr-object "The root parent of all FCR classes"
+                       nil nil '(fcr-object)))
+(defun fcr--object-p (fcr)
+  (let ((type (fcr-type fcr)))
+    (when type
+      (memq 'fcr-object (fcr--class-allparents (cl--find-class type))))))
+(cl-deftype fcr-object () '(satisfies fcr--object-p))
+
+(defun fcr--defstruct-make-copiers (copiers slots name)
+  (require 'cl-macs)                    ;`cl--arglist-args' is not autoloaded.
+  (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))
+          (index -1)
+          (argvals
+           (mapcar
+           (lambda (slot)
+             (setq index (1+ index))
+             (when (memq slot anames)
+               ;; FIXME: Skip the `unless' test for mandatory args.
+               `(if (eq ',absent ,slot)
+                    (fcr-get ,obj ,index)
+                  ,slot)))
+           slots)))
+       `(cl-defsubst ,cname (&cl-defs (',absent) ,obj ,@args)
+          ,doc
+          (declare (side-effect-free t))
+          (fcr--copy ,obj ,@argvals))))
+   copiers))
+
+(defmacro fcr-defstruct (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))
+                           '(fcr-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)
+                               (cl--make-slot-descriptor field nil nil
+                                                         '((:read-only . t))))
+                             slots)))
+         (allparents (apply #'append (mapcar #'cl--generic-class-parents
+                                             parents)))
+         (class (fcr--class-make name docstring slotdescs parents
+                                 (delete-dups
+                                  (cons name allparents)))))
+    ;; FIXME: Use an intermediate function like `cl-struct-define'.
+    `(progn
+       ,(when options (macroexp-warn-and-return
+                       (format "Ignored options: %S" options)
+                       nil))
+       (eval-and-compile
+         (fcr--define ',class
+                      (lambda (fcr)
+                        (let ((type (fcr-type fcr)))
+                          (when type
+                            (memq ',name (fcr--class-allparents
+                                          (cl--find-class type))))))))
+       ,@(let ((i -1))
+           (mapcar (lambda (desc)
+                     (let ((slot (cl--slot-descriptor-name desc)))
+                       (cl-incf 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)) (fcr)
+                        ,(format "Return slot `%S' of FCR, of type `%S'."
+                                 slot name)
+                        (fcr-get fcr ,i))))
+                   slotdescs))
+       ,@(fcr--defstruct-make-copiers copiers slots name))))
+
+(defun fcr--define (class pred)
+  (let* ((name (cl--class-name class))
+         (predname (intern (format "fcr--%s-p" name))))
+    (setf (cl--find-class name) class)
+    (defalias predname pred)
+    ;; Yuck!
+    (eval `(cl-deftype ,name () '(satisfies ,predname)) t)))
+
+(defmacro fcr-make (type fields args &rest body)
+  (declare (indent 3) (debug (sexp (&rest (sexp form)) sexp def-body)))
+  ;; FIXME: Provide the fields in the order specified by `type'.
+  (let* ((class (cl--find-class type))
+         (slots (fcr--class-slots class))
+         (slotbinds (nreverse
+                     (mapcar (lambda (slot)
+                               (list (cl--slot-descriptor-name slot)))
+                             slots)))
+         (tempbinds (mapcar
+                     (lambda (field)
+                       (let* ((name (car field))
+                              (bind (assq name slotbinds)))
+                         (cond
+                          ((not bind)
+                           (error "Unknown slots: %S" name))
+                          ((cdr bind)
+                           (error "Duplicate slots: %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!
+    ;; FIXME: Slots not specified in `fields' tend to emit "Variable FOO left
+    ;; uninitialized"!
+    `(let ,tempbinds
+       (let ,slotbinds
+         ;; FIXME: Prevent store-conversion for fields vars!
+         ;; FIXME: Set the object's *type*!
+         ;; 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).
+         (fcr--fix-type
+          (lambda ,args
+            (:documentation ',type)
+            ;; Add dummy code which accesses the field's vars to make sure
+            ;; they're captured in the closure.
+            (if t nil ,@(mapcar #'car fields))
+            ,@body))))))
+
+(defvar fcr--type-sym (make-symbol ":type"))
+
+(defun fcr--fix-type (fcr)
+  (if (byte-code-function-p fcr)
+      fcr
+    ;; 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 fcr)))
+    (let ((typename (documentation fcr 'raw)))
+      (push (cons fcr--type-sym (intern typename))
+            (cadr fcr))
+      fcr)))
+
+(defun fcr--copy (fcr &rest args)
+  (if (byte-code-function-p fcr)
+      (apply #'make-closure fcr args)
+    (cl-assert (eq 'closure (car-safe fcr)))
+    (cl-assert (eq fcr--type-sym (caar (cadr fcr))))
+    (let ((env (cadr fcr)))
+      `(closure
+           (,(car env)
+            ,@(cl-mapcar (lambda (b v) (cons (car b) v)) (cdr env) args)
+            ,@(nthcdr (1+ (length args)) env))
+           ,@(nthcdr 2 fcr)))))
+
+(defun fcr-get (fcr index)
+  (if (byte-code-function-p fcr)
+      (let ((csts (aref fcr 2)))
+        (aref csts index))
+    (cl-assert (eq 'closure (car-safe fcr)))
+    (cl-assert (eq fcr--type-sym (caar (cadr fcr))))
+    (cdr (nth (1+ index) (cadr fcr)))))
+
+(defun fcr-type (fcr)
+  "Return the type of FCR, or nil if the arg is not a FunCallableRecord."
+  (if (byte-code-function-p fcr)
+      (let ((type (and (> (length fcr) 4) (aref fcr 4))))
+        (if (symbolp type) type))
+    (and (eq 'closure (car-safe fcr))
+         (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/src/eval.c b/src/eval.c
index fe29564..1942fbd 100644
--- a/src/eval.c
+++ b/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))));
        }
diff --git a/test/lisp/emacs-lisp/fcr-tests.el 
b/test/lisp/emacs-lisp/fcr-tests.el
new file mode 100644
index 0000000..8df61ed
--- /dev/null
+++ b/test/lisp/emacs-lisp/fcr-tests.el
@@ -0,0 +1,75 @@
+;;; fcr-tests.e; --- Tests for FunCallableRecords  -*- 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 'fcr)
+(require 'cl-lib)
+
+(fcr-defstruct (fcr-test
+                ;; FIXME: Test `:parent'!
+                (:copier fcr-test-copy))
+  "Simple FCR."
+  fst snd name)
+
+(cl-defmethod fcr-test-gen ((_x compiled-function)) "#<bytecode>")
+
+(cl-defmethod fcr-test-gen ((_x cons)) "#<cons>")
+
+(cl-defmethod fcr-test-gen ((_x fcr-object))
+  (format "#<fcr:%s>" (cl-call-next-method)))
+
+(cl-defmethod fcr-test-gen ((_x fcr-test))
+  (format "#<fcr-test:%s>" (cl-call-next-method)))
+
+(ert-deftest fcr-tests ()
+  (let* ((i 42)
+         (fcr1 (fcr-make fcr-test ((fst 1) (snd 2) (name "hi"))
+                         ()
+                         (list fst snd i)))
+         (fcr2 (fcr-make fcr-test ((name (cl-incf i)) (fst (cl-incf i)))
+                         ()
+                         (list fst snd 152 i))))
+    (message "hello-1")
+    (should (equal (list (fcr-test--fst fcr1)
+                         (fcr-test--snd fcr1)
+                         (fcr-test--name fcr1))
+                   '(1 2 "hi")))
+    (message "hello-2")
+    (should (equal (list (fcr-test--fst fcr2)
+                         (fcr-test--snd fcr2)
+                         (fcr-test--name fcr2))
+                   '(44 nil 43)))
+    (message "hello-3")
+    (should (equal (funcall fcr1) '(1 2 44)))
+    (message "hello-4")
+    (should (equal (funcall fcr2) '(44 nil 152 44)))
+    (message "hello-5")
+    (should (equal (funcall (fcr-test-copy fcr1 :fst 7)) '(7 2 44)))
+    (message "hello-6")
+    (should (cl-typep fcr1 'fcr-test))
+    (message "hello-7")
+    (should (cl-typep fcr1 'fcr-object))
+    (should (member (fcr-test-gen fcr1)
+                    '("#<fcr-test:#<fcr:#<cons>>>"
+                      "#<fcr-test:#<fcr:#<bytecode>>>")))
+    ))
+
+;;; fcr-tests.el ends here.