From: Stefan Monnier Date: Sun, 12 Dec 2021 17:12:30 +0000 (-0500) Subject: OClosure: Hybrids between functions and defstructs X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=ae493f3513d0ffb0da3992a51b871bba0a9971e4;p=emacs.git OClosure: Hybrids between functions and defstructs * lisp/emacs-lisp/oclosure.el: New file. * test/lisp/emacs-lisp/oclosure-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. --- diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 7cec91bfa82..97066da0ee7 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 OClosure: `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/oclosure.el b/lisp/emacs-lisp/oclosure.el new file mode 100644 index 00000000000..22ce26c1f88 --- /dev/null +++ b/lisp/emacs-lisp/oclosure.el @@ -0,0 +1,305 @@ +;;; oclosure.el --- Open Closures -*- 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 OClosure 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 OClosures 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 (oclosure--class + (:constructor nil) + (:constructor oclosure--class-make ( name docstring slots parents + allparents)) + (:include cl--class) + (:copier nil)) + "Metaclass for OClosure classes." + (allparents nil :read-only t :type (list-of symbol))) + +(setf (cl--find-class 'oclosure-object) + (oclosure--class-make 'oclosure-object "The root parent of all OClosure classes" + nil nil '(oclosure-object))) +(defun oclosure--object-p (oclosure) + (let ((type (oclosure-type oclosure))) + (when type + (memq 'oclosure-object (oclosure--class-allparents (cl--find-class type)))))) +(cl-deftype oclosure-object () '(satisfies oclosure--object-p)) + +(defun oclosure--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) + (oclosure-get ,obj ,index) + ,slot))) + slots))) + `(cl-defsubst ,cname (&cl-defs (',absent) ,obj ,@args) + ,doc + (declare (side-effect-free t)) + (oclosure--copy ,obj ,@argvals)))) + copiers)) + +(defmacro oclosure-define (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)) + '(oclosure-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 (oclosure--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 + (oclosure--define ',class + (lambda (oclosure) + (let ((type (oclosure-type oclosure))) + (when type + (memq ',name (oclosure--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)) (oclosure) + ,(format "Return slot `%S' of OClosure, of type `%S'." + slot name) + (oclosure-get oclosure ,i)))) + slotdescs)) + ,@(oclosure--defstruct-make-copiers copiers slots name)))) + +(defun oclosure--define (class pred) + (let* ((name (cl--class-name class)) + (predname (intern (format "oclosure--%s-p" name)))) + (setf (cl--find-class name) class) + (defalias predname pred) + ;; Yuck! + (eval `(cl-deftype ,name () '(satisfies ,predname)) t))) + +(defmacro oclosure-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 (oclosure--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). + (oclosure--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 oclosure--type-sym (make-symbol ":type")) + +(defun oclosure--fix-type (oclosure) + (if (byte-code-function-p oclosure) + oclosure + ;; 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 oclosure))) + (let ((typename (documentation oclosure 'raw))) + (push (cons oclosure--type-sym (intern typename)) + (cadr oclosure)) + oclosure))) + +(defun oclosure--copy (oclosure &rest args) + (if (byte-code-function-p oclosure) + (apply #'make-closure oclosure args) + (cl-assert (eq 'closure (car-safe oclosure))) + (cl-assert (eq oclosure--type-sym (caar (cadr oclosure)))) + (let ((env (cadr oclosure))) + `(closure + (,(car env) + ,@(cl-mapcar (lambda (b v) (cons (car b) v)) (cdr env) args) + ,@(nthcdr (1+ (length args)) env)) + ,@(nthcdr 2 oclosure))))) + +(defun oclosure-get (oclosure index) + (if (byte-code-function-p oclosure) + (let ((csts (aref oclosure 2))) + (aref csts index)) + (cl-assert (eq 'closure (car-safe oclosure))) + (cl-assert (eq oclosure--type-sym (caar (cadr oclosure)))) + (cdr (nth (1+ index) (cadr oclosure))))) + +(defun oclosure-type (oclosure) + "Return the type of OCLOSURE, or nil if the arg is not a OClosure." + (if (byte-code-function-p oclosure) + (let ((type (and (> (length oclosure) 4) (aref oclosure 4)))) + (if (symbolp type) type)) + (and (eq 'closure (car-safe oclosure)) + (eq oclosure--type-sym (caar (cadr oclosure))) + (cdar (cadr oclosure))))) + +;;; Support for cl-generic + +(defun oclosure--struct-tag (name &rest _) + `(oclosure-type ,name)) + +(defun oclosure--struct-specializers (tag &rest _) + (and (symbolp tag) + (let ((class (cl--find-class tag))) + (when (cl-typep class 'oclosure--class) + (cl--generic-class-parents class))))) + +(cl-generic-define-generalizer oclosure--struct-generalizer + 50 #'oclosure--struct-tag + #'oclosure--struct-specializers) + +(cl-defmethod cl-generic-generalizers :extra "oclosure-struct" (type) + "Support for dispatch on types defined by `oclosure-define'." + (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 'oclosure--class) + (list oclosure--struct-generalizer)))) + (cl-call-next-method))) + + + +(provide 'oclosure) +;;; oclosure.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/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el new file mode 100644 index 00000000000..b5436e5ea20 --- /dev/null +++ b/test/lisp/emacs-lisp/oclosure-tests.el @@ -0,0 +1,75 @@ +;;; oclosure-tests.e; --- Tests for Open Closures -*- 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 'oclosure) +(require 'cl-lib) + +(oclosure-define (oclosure-test + ;; FIXME: Test `:parent'! + (:copier oclosure-test-copy)) + "Simple OClosure." + fst snd name) + +(cl-defmethod oclosure-test-gen ((_x compiled-function)) "#") + +(cl-defmethod oclosure-test-gen ((_x cons)) "#") + +(cl-defmethod oclosure-test-gen ((_x oclosure-object)) + (format "#" (cl-call-next-method))) + +(cl-defmethod oclosure-test-gen ((_x oclosure-test)) + (format "#" (cl-call-next-method))) + +(ert-deftest oclosure-tests () + (let* ((i 42) + (ocl1 (oclosure-make oclosure-test ((fst 1) (snd 2) (name "hi")) + () + (list fst snd i))) + (ocl2 (oclosure-make oclosure-test ((name (cl-incf i)) (fst (cl-incf i))) + () + (list fst snd 152 i)))) + (message "hello-1") + (should (equal (list (oclosure-test--fst ocl1) + (oclosure-test--snd ocl1) + (oclosure-test--name ocl1)) + '(1 2 "hi"))) + (message "hello-2") + (should (equal (list (oclosure-test--fst ocl2) + (oclosure-test--snd ocl2) + (oclosure-test--name ocl2)) + '(44 nil 43))) + (message "hello-3") + (should (equal (funcall ocl1) '(1 2 44))) + (message "hello-4") + (should (equal (funcall ocl2) '(44 nil 152 44))) + (message "hello-5") + (should (equal (funcall (oclosure-test-copy ocl1 :fst 7)) '(7 2 44))) + (message "hello-6") + (should (cl-typep ocl1 'oclosure-test)) + (message "hello-7") + (should (cl-typep ocl1 'oclosure-object)) + (should (member (oclosure-test-gen ocl1) + '("#>>" + "#>>"))) + )) + +;;; oclosure-tests.el ends here.