[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
scratch/oclosure ae493f3513 01/25: OClosure: Hybrids between functions a
From: |
Stefan Monnier |
Subject: |
scratch/oclosure ae493f3513 01/25: OClosure: Hybrids between functions and defstructs |
Date: |
Fri, 31 Dec 2021 15:40:55 -0500 (EST) |
branch: scratch/oclosure
commit ae493f3513d0ffb0da3992a51b871bba0a9971e4
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>
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.
---
lisp/emacs-lisp/cconv.el | 14 +-
lisp/emacs-lisp/oclosure.el | 305 +++++++++++++++++++++++++++++++++
src/eval.c | 4 +
test/lisp/emacs-lisp/oclosure-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 7cec91bfa8..97066da0ee 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 0000000000..22ce26c1f8
--- /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 <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 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 fe29564aa2..1942fbdfb8 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/oclosure-tests.el
b/test/lisp/emacs-lisp/oclosure-tests.el
new file mode 100644
index 0000000000..b5436e5ea2
--- /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 <https://www.gnu.org/licenses/>.
+
+;;; 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)) "#<bytecode>")
+
+(cl-defmethod oclosure-test-gen ((_x cons)) "#<cons>")
+
+(cl-defmethod oclosure-test-gen ((_x oclosure-object))
+ (format "#<oclosure:%s>" (cl-call-next-method)))
+
+(cl-defmethod oclosure-test-gen ((_x oclosure-test))
+ (format "#<oclosure-test:%s>" (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-test:#<oclosure:#<cons>>>"
+ "#<oclosure-test:#<oclosure:#<bytecode>>>")))
+ ))
+
+;;; oclosure-tests.el ends here.
- branch scratch/oclosure created (now de320e2003), Stefan Monnier, 2021/12/31
- scratch/oclosure 5574871ec7 09/25: nadvice.el: Use OClosures rather than handmade bytecodes, Stefan Monnier, 2021/12/31
- scratch/oclosure f11349ed20 03/25: * lisp/emacs-lisp/cl-generic.el: Use OClosure for `cl-next-method-p`, Stefan Monnier, 2021/12/31
- scratch/oclosure 230617c90c 16/25: lisp/emacs-lisp/oclosure.el: Signal errors for invalid code, Stefan Monnier, 2021/12/31
- scratch/oclosure e052bb2770 04/25: * lisp/kmacro.el: Use OClosure instead of messing with internals, Stefan Monnier, 2021/12/31
- scratch/oclosure ae493f3513 01/25: OClosure: Hybrids between functions and defstructs,
Stefan Monnier <=
- scratch/oclosure ae0bfc4f75 05/25: * lisp/loadup.el (oclosure): Load before `nadvice`, Stefan Monnier, 2021/12/31
- scratch/oclosure afa68def26 11/25: cl-print.el: Dispatch on `advice` type, Stefan Monnier, 2021/12/31
- scratch/oclosure fe5457ff75 19/25: oclosure.el (oclosure-lambda): Change calling convention, Stefan Monnier, 2021/12/31
- scratch/oclosure d93b0ad4d4 06/25: (interactive-form, function-docstring): New generic functions, Stefan Monnier, 2021/12/31
- scratch/oclosure a444d85977 08/25: Fix bootstrap problems and various misc issues found along the way, Stefan Monnier, 2021/12/31
- scratch/oclosure f44ee8cd53 17/25: oclosure.el (accessor): New type, Stefan Monnier, 2021/12/31
- scratch/oclosure 55a8e92413 20/25: oclosure.el: Add support for mutable slots, Stefan Monnier, 2021/12/31
- scratch/oclosure bc1d94a0d8 21/25: * lisp/emacs-lisp/oclosure.el (Commentary:): Add a few notes, Stefan Monnier, 2021/12/31
- scratch/oclosure 263172dbfb 02/25: lisp/emacs-lisp/oclosure.el: Make it available to cl-generic, Stefan Monnier, 2021/12/31
- scratch/oclosure 3119e59252 07/25: lisp/emacs-lisp/oclosure.el: Rename `oclosure-make` to `oclosure-lambda`, Stefan Monnier, 2021/12/31