From 780957c915824fd01924415a6ed73d7dac35630c Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sun, 12 Dec 2021 12:12:30 -0500 Subject: [PATCH] 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(-) create mode 100644 lisp/emacs-lisp/fcr.el create mode 100644 test/lisp/emacs-lisp/fcr-tests.el diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 7cec91bfa82..d1c7bc0e51a 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 00000000000..028d289221a --- /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 +;; 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 . + +;;; 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 fe29564aa2d..1942fbdfb81 100644 --- a/src/eval.c +++ b/src/eval.c @@ -574,6 +574,10 @@ usage: (function ARG) */) { /* Handle the special (:documentation
) 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 00000000000..8df61ed8ea4 --- /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 . + +;;; 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)) "#") + +(cl-defmethod fcr-test-gen ((_x cons)) "#") + +(cl-defmethod fcr-test-gen ((_x fcr-object)) + (format "#" (cl-call-next-method))) + +(cl-defmethod fcr-test-gen ((_x fcr-test)) + (format "#" (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-tests.el ends here. -- 2.39.5