From: Stefan Monnier Date: Wed, 14 Jan 2015 19:37:10 +0000 (-0500) Subject: * lisp/emacs-lisp/cl-generic.el: New file. X-Git-Tag: emacs-25.0.90~2603^2~2 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=9def17e92bbb61e877bf092b562a92946cf43210;p=emacs.git * lisp/emacs-lisp/cl-generic.el: New file. * lisp/emacs-lisp/cl-macs.el (cl-flet): Allow (FUN EXP) forms. (cl-load-time-value, cl-labels): Use closures rather than backquoted lambdas. (cl-macrolet): Use `eval' to create the function value, and support CL style arguments in for the defined macros. * test/automated/cl-generic-tests.el: New file. --- diff --git a/etc/NEWS b/etc/NEWS index b3267e1ce60..f291c0c9ad9 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -480,6 +480,8 @@ As a result of the above, these commands are now obsolete: * New Modes and Packages in Emacs 25.1 +** cl-generic.el provides CLOS-style multiple-dispatch generic functions. + ** scss-mode (a minor variant of css-mode) ** let-alist is a new macro (and a package) that allows one to easily diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 6e2adc9b8e1..e0fb3cced0c 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,13 @@ +2015-01-14 Stefan Monnier + + * emacs-lisp/cl-generic.el: New file. + + * emacs-lisp/cl-macs.el (cl-flet): Allow (FUN EXP) forms. + (cl-load-time-value, cl-labels): Use closures rather than + backquoted lambdas. + (cl-macrolet): Use `eval' to create the function value, and support CL + style arguments in for the defined macros. + 2015-01-14 Stefan Monnier * net/eww.el: Use lexical-binding. diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el new file mode 100644 index 00000000000..19e4ce0fbef --- /dev/null +++ b/lisp/emacs-lisp/cl-generic.el @@ -0,0 +1,605 @@ +;;; cl-generic.el --- CLOS-style generic functions for Elisp -*- lexical-binding: t; -*- + +;; Copyright (C) 2015 Stefan Monnier + +;; Author: Stefan Monnier + +;; 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: + +;; This implements the most of CLOS's multiple-dispatch generic functions. +;; To use it you need either (require 'cl-generic) or (require 'cl-lib). +;; The main entry points are: `cl-defgeneric' and `cl-defmethod'. + +;; Missing elements: +;; - We don't support next-method-p, make-method, call-method, +;; define-method-combination. +;; - Method and generic function objects: CLOS defines methods as objects +;; (same for generic functions), whereas we don't offer such an abstraction. +;; - `no-next-method' should receive the "calling method" object, but since we +;; don't have such a thing, we pass nil instead. +;; - In defgeneric we don't support the options: +;; declare, :method-combination, :generic-function-class, :method-class, +;; :method. +;; Added elements: +;; - We support aliases to generic functions. +;; - The kind of thing on which to dispatch can be extended. +;; There is support in this file for (eql ) dispatch as well as dispatch +;; on the type of CL structs, and eieio-core.el adds support for EIEIO +;; defclass objects. + +;;; Code: + +;; Note: For generic functions that dispatch on several arguments (i.e. those +;; which use the multiple-dispatch feature), we always use the same "tagcodes" +;; and the same set of arguments on which to dispatch. This works, but is +;; often suboptimal since after one dispatch, the remaining dispatches can +;; usually be simplified, or even completely skipped. + +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'pcase)) + +(defvar cl-generic-tagcode-function + (lambda (type _name) + (if (eq type t) '(0 . 'cl--generic-type) + (error "Unknown specializer %S" type))) + "Function to get the Elisp code to extract the tag on which we dispatch. +Takes a \"parameter-specializer-name\" and a variable name, and returns +a pair (PRIORITY . CODE) where CODE is an Elisp expression that should be +used to extract the \"tag\" (from the object held in the named variable) +that should uniquely determine if we have a match +\(i.e. the \"tag\" is the value that will be used to dispatch to the proper +method(s)). +Such \"tagcodes\" will be or'd together. +PRIORITY is an integer from 0 to 100 which is used to sort the tagcodes +in the `or'. The higher the priority, the more specific the tag should be. +More specifically, if PRIORITY is N and we have two objects X and Y +whose tag (according to TAGCODE) is `eql', then it should be the case +that for all other (PRIORITY . TAGCODE) where PRIORITY ≤ N, then +\(eval TAGCODE) for X is `eql' to (eval TAGCODE) for Y.") + +(defvar cl-generic-tag-types-function + (lambda (tag) (if (eq tag 'cl--generic-type) '(t))) + "Function to get the list of types that a given \"tag\" matches. +They should be sorted from most specific to least specific.") + +(cl-defstruct (cl--generic + (:constructor nil) + (:constructor cl--generic-make + (name &optional dispatches method-table)) + (:predicate nil)) + (name nil :read-only t) ;Pointer back to the symbol. + ;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index + ;; of the corresponding argument and TAGCODES is a list of (PRIORITY . EXP) + ;; where the EXPs are expressions (to be `or'd together) to compute the tag + ;; on which to dispatch and PRIORITY is the priority of each expression to + ;; decide in which order to sort them. + ;; The most important dispatch is last in the list (and the least is first). + dispatches + ;; `method-table' is a list of + ;; ((SPECIALIZERS . QUALIFIER) USES-CNM . FUNCTION), where + ;; USES-CNM is a boolean indicating if FUNCTION calls `cl-call-next-method' + ;; (and hence expects an extra argument holding the next-method). + method-table) + +(defmacro cl--generic (name) + `(get ,name 'cl--generic)) + +(defun cl-generic-ensure-function (name) + (let (generic + (origname name)) + (while (and (null (setq generic (cl--generic name))) + (fboundp name) + (symbolp (symbol-function name))) + (setq name (symbol-function name))) + (unless (or (not (fboundp name)) + (and (functionp name) generic)) + (error "%s is already defined as something else than a generic function" + origname)) + (if generic + (cl-assert (eq name (cl--generic-name generic))) + (setf (cl--generic name) (setq generic (cl--generic-make name))) + (defalias name (cl--generic-make-function generic))) + generic)) + +(defun cl--generic-setf-rewrite (name) + (let ((setter (intern (format "cl-generic-setter--%s" name)))) + (cons setter + `(eval-and-compile + (unless (eq ',setter (get ',name 'cl-generic-setter)) + ;; (when (get ',name 'gv-expander) + ;; (error "gv-expander conflicts with (setf %S)" ',name)) + (setf (get ',name 'cl-generic-setter) ',setter) + (gv-define-setter ,name (val &rest args) + (cons ',setter (cons val args)))))))) + +;;;###autoload +(defmacro cl-defgeneric (name args &rest options-and-methods) + "Create a generic function NAME. +DOC-STRING is the base documentation for this class. A generic +function has no body, as its purpose is to decide which method body +is appropriate to use. Specific methods are defined with `defmethod'. +With this implementation the ARGS are currently ignored. +OPTIONS-AND-METHODS is currently only used to specify the docstring, +via (:documentation DOCSTRING)." + (declare (indent 2) (doc-string 3)) + (let* ((docprop (assq :documentation options-and-methods)) + (doc (cond ((stringp (car-safe options-and-methods)) + (pop options-and-methods)) + (docprop + (prog1 + (cadr docprop) + (setq options-and-methods + (delq docprop options-and-methods))))))) + `(progn + ,(when (eq 'setf (car-safe name)) + (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite + (cadr name)))) + (setq name setter) + code)) + (defalias ',name + (cl-generic-define ',name ',args ',options-and-methods) + ,doc)))) + +(defun cl--generic-mandatory-args (args) + (let ((res ())) + (while (not (memq (car args) '(nil &rest &optional &key))) + (push (pop args) res)) + (nreverse res))) + +;;;###autoload +(defun cl-generic-define (name args options-and-methods) + (let ((generic (cl-generic-ensure-function name)) + (mandatory (cl--generic-mandatory-args args)) + (apo (assq :argument-precedence-order options-and-methods))) + (setf (cl--generic-dispatches generic) nil) + (when apo + (dolist (arg (cdr apo)) + (let ((pos (memq arg mandatory))) + (unless pos (error "%S is not a mandatory argument" arg)) + (push (list (- (length mandatory) (length pos))) + (cl--generic-dispatches generic))))) + (setf (cl--generic-method-table generic) nil) + (cl--generic-make-function generic))) + +(defvar cl-generic-current-method-specializers nil + ;; This is let-bound during macro-expansion of method bodies, so that those + ;; bodies can be optimized knowing that the specializers have matched. + ;; FIXME: This presumes the formal arguments aren't modified via `setq' and + ;; aren't shadowed either ;-( + ;; FIXME: This might leak outside the scope of the method if, during + ;; macroexpansion of the method, something causes some other macroexpansion + ;; (e.g. an autoload). + "List of (VAR . TYPE) where TYPE is var's specializer.") + +(eval-and-compile ;Needed while compiling the cl-defmethod calls below! + (defun cl--generic-fgrep (vars sexp) ;Copied from pcase.el. + "Check which of the symbols VARS appear in SEXP." + (let ((res '())) + (while (consp sexp) + (dolist (var (cl--generic-fgrep vars (pop sexp))) + (unless (memq var res) (push var res)))) + (and (memq sexp vars) (not (memq sexp res)) (push sexp res)) + res)) + + (defun cl--generic-lambda (args body with-cnm) + "Make the lambda expression for a method with ARGS and BODY." + (let ((plain-args ()) + (cl-generic-current-method-specializers nil) + (doc-string (if (stringp (car-safe body)) (pop body))) + (mandatory t)) + (dolist (arg args) + (push (pcase arg + ((or '&optional '&rest '&key) (setq mandatory nil) arg) + ((and `(,name . ,type) (guard mandatory)) + (push (cons name (car type)) + cl-generic-current-method-specializers) + name) + (_ arg)) + plain-args)) + (setq plain-args (nreverse plain-args)) + (let ((fun `(cl-function (lambda ,plain-args + ,@(if doc-string (list doc-string)) + ,@body)))) + (if (not with-cnm) + (cons nil fun) + ;; First macroexpand away the cl-function stuff (e.g. &key and + ;; destructuring args, `declare' and whatnot). + (pcase (macroexpand fun macroexpand-all-environment) + (`#'(lambda ,args . ,body) + (require 'cl-lib) ;Needed to expand `cl-flet'. + (let* ((doc-string (and doc-string (stringp (car body)) + (pop body))) + (cnm (make-symbol "cl--cnm")) + (nbody (macroexpand-all + `(cl-flet ((cl-call-next-method ,cnm)) + ,@body) + macroexpand-all-environment)) + ;; FIXME: Rather than `grep' after the fact, the + ;; macroexpansion should directly set some flag when cnm + ;; is used. + ;; FIXME: Also, optimize the case where call-next-method is + ;; only called with explicit arguments. + (uses-cnm (cl--generic-fgrep (list cnm) nbody))) + (cons (not (not uses-cnm)) + `#'(lambda (,@(if uses-cnm (list cnm)) ,@args) + ,@(if doc-string (list doc-string)) + ,nbody)))) + (f (error "Unexpected macroexpansion result: %S" f)))))))) + + +;;;###autoload +(defmacro cl-defmethod (name args &rest body) + "Define a new method for generic function NAME. +I.e. it defines the implementation of NAME to use for invocations where the +value of the dispatch argument matches the specified TYPE. +The dispatch argument has to be one of the mandatory arguments, and +all methods of NAME have to use the same argument for dispatch. +The dispatch argument and TYPE are specified in ARGS where the corresponding +formal argument appears as (VAR TYPE) rather than just VAR. + +The optional second argument QUALIFIER is a specifier that +modifies how the method is combined with other methods, including: + :before - Method will be called before the primary + :after - Method will be called after the primary + :around - Method will be called around everything else +The absence of QUALIFIER means this is a \"primary\" method. + +Other than a type, TYPE can also be of the form `(eql VAL)' in +which case this method will be invoked when the argument is `eql' to VAL. + +\(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)" + (declare (doc-string 3) (indent 2)) + (let ((qualifiers nil)) + (while (keywordp args) + (push args qualifiers) + (setq args (pop body))) + (pcase-let* ((with-cnm (not (memq (car qualifiers) '(:before :after)))) + (`(,uses-cnm . ,fun) (cl--generic-lambda args body with-cnm))) + `(progn + ,(when (eq 'setf (car-safe name)) + (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite + (cadr name)))) + (setq name setter) + code)) + (cl-generic-define-method ',name ',qualifiers ',args + ,uses-cnm ,fun))))) + +;;;###autoload +(defun cl-generic-define-method (name qualifiers args uses-cnm function) + (when (> (length qualifiers) 1) + (error "We only support a single qualifier per method: %S" qualifiers)) + (unless (memq (car qualifiers) '(nil :primary :around :after :before)) + (error "Unsupported qualifier in: %S" qualifiers)) + (let* ((generic (cl-generic-ensure-function name)) + (mandatory (cl--generic-mandatory-args args)) + (specializers + (mapcar (lambda (arg) (if (consp arg) (cadr arg) t)) mandatory)) + (key (cons specializers (or (car qualifiers) ':primary))) + (mt (cl--generic-method-table generic)) + (me (assoc key mt)) + (dispatches (cl--generic-dispatches generic)) + (i 0)) + (dolist (specializer specializers) + (let* ((tagcode (funcall cl-generic-tagcode-function specializer 'arg)) + (x (assq i dispatches))) + (if (not x) + (setf (cl--generic-dispatches generic) + (setq dispatches (cons (list i tagcode) dispatches))) + (unless (member tagcode (cdr x)) + (setf (cdr x) + (nreverse (sort (cons tagcode (cdr x)) + #'car-less-than-car))))) + (setq i (1+ i)))) + (if me (setcdr me (cons uses-cnm function)) + (setf (cl--generic-method-table generic) + (cons `(,key ,uses-cnm . ,function) mt)) + ;; For aliases, cl--generic-name gives us the actual name. + (defalias (cl--generic-name generic) + (cl--generic-make-function generic))))) + +(defmacro cl--generic-with-memoization (place &rest code) + (declare (indent 1) (debug t)) + (gv-letplace (getter setter) place + `(or ,getter + ,(macroexp-let2 nil val (macroexp-progn code) + `(progn + ,(funcall setter val) + ,val))))) + +(defvar cl--generic-dispatchers (make-hash-table :test #'equal)) + +(defun cl--generic-get-dispatcher (tagcodes dispatch-arg) + (cl--generic-with-memoization + (gethash (cons dispatch-arg tagcodes) cl--generic-dispatchers) + (let ((lexical-binding t) + (extraargs ())) + (dotimes (_ dispatch-arg) + (push (make-symbol "arg") extraargs)) + (byte-compile + `(lambda (generic dispatches-left) + (let ((method-cache (make-hash-table :test #'eql))) + (lambda (,@extraargs arg &rest args) + (apply (cl--generic-with-memoization + (gethash (or ,@(mapcar #'cdr tagcodes)) method-cache) + (cl--generic-cache-miss + generic ',dispatch-arg dispatches-left + (list ,@(mapcar #'cdr tagcodes)))) + ,@extraargs arg args)))))))) + +(defun cl--generic-make-function (generic) + (let* ((dispatches (cl--generic-dispatches generic)) + (dispatch + (progn + (while (and dispatches + (member (cdar dispatches) + '(nil ((0 . 'cl--generic-type))))) + (setq dispatches (cdr dispatches))) + (pop dispatches)))) + (if (null dispatch) + (cl--generic-build-combined-method + (cl--generic-name generic) + (cl--generic-method-table generic)) + (let ((dispatcher (cl--generic-get-dispatcher + (cdr dispatch) (car dispatch)))) + (funcall dispatcher generic dispatches))))) + +(defun cl--generic-nest (fun methods) + (pcase-dolist (`(,uses-cnm . ,method) methods) + (setq fun + (if (not uses-cnm) method + (let ((next fun)) + (lambda (&rest args) + (apply method + ;; FIXME: This sucks: passing just `next' would + ;; be a lot more efficient than the lambda+apply + ;; quasi-η, but we need this to implement the + ;; "if call-next-method is called with no + ;; arguments, then use the previous arguments". + (lambda (&rest cnm-args) + (apply next (or cnm-args args))) + args)))))) + fun) + +(defvar cl--generic-combined-method-memoization + (make-hash-table :test #'equal :weakness 'value) + "Table storing previously built combined-methods. +This is particularly useful when many different tags select the same set +of methods, since this table then allows us to share a single combined-method +for all those different tags in the method-cache.") + +(defun cl--generic-build-combined-method (generic-name methods) + (let ((mets-by-qual ())) + (dolist (qm methods) + (push (cdr qm) (alist-get (cdar qm) mets-by-qual))) + (cl--generic-with-memoization + (gethash (cons generic-name mets-by-qual) + cl--generic-combined-method-memoization) + (cond + ((null mets-by-qual) (lambda (&rest args) + (cl-no-applicable-method generic-name args))) + (t + (let* ((fun (lambda (&rest args) + ;; FIXME: CLOS passes as second arg the "calling method". + ;; We don't currently have "method objects" like CLOS + ;; does so we can't really do it the CLOS way. + ;; The closest would be to pass the lambda corresponding + ;; to the method, but the caller wouldn't be able to do + ;; much with it anyway. So we pass nil for now. + (apply #'cl-no-next-method generic-name nil args))) + ;; We use `cdr' to drop the `uses-cnm' annotations. + (before + (mapcar #'cdr (reverse (alist-get :before mets-by-qual)))) + (after (mapcar #'cdr (alist-get :after mets-by-qual)))) + (setq fun (cl--generic-nest fun (alist-get :primary mets-by-qual))) + (when (or after before) + (let ((next fun)) + (setq fun (lambda (&rest args) + (dolist (bf before) + (apply bf args)) + (apply next args) + (dolist (af after) + (apply af args)))))) + (cl--generic-nest fun (alist-get :around mets-by-qual)))))))) + +(defun cl--generic-cache-miss (generic dispatch-arg dispatches-left tags) + (let ((types (apply #'append (mapcar cl-generic-tag-types-function tags))) + (methods '())) + (dolist (method-desc (cl--generic-method-table generic)) + (let ((m (member (nth dispatch-arg (caar method-desc)) types))) + (when m + (push (cons (length m) method-desc) methods)))) + ;; Sort the methods, most specific first. + ;; It would be tempting to sort them once and for all in the method-table + ;; rather than here, but the order might depend on the actual argument + ;; (e.g. for multiple inheritance with defclass). + (setq methods (nreverse (mapcar #'cdr (sort methods #'car-less-than-car)))) + (cl--generic-make-function (cl--generic-make (cl--generic-name generic) + dispatches-left methods)))) + +;;; Define some pre-defined generic functions, used internally. + +(define-error 'cl-no-method "No method for %S") +(define-error 'cl-no-next-method "No next method for %S" 'cl-no-method) +(define-error 'cl-no-applicable-method "No applicable method for %S" + 'cl-no-method) + +(cl-defgeneric cl-no-next-method (generic method &rest args) + "Function called when `cl-call-next-method' finds no next method.") +(cl-defmethod cl-no-next-method ((generic t) method &rest args) + (signal 'cl-no-next-method `(,generic ,method ,@args))) + +(cl-defgeneric cl-no-applicable-method (generic &rest args) + "Function called when a method call finds no applicable method.") +(cl-defmethod cl-no-applicable-method ((generic t) &rest args) + (signal 'cl-no-applicable-method `(,generic ,@args))) + +(defun cl-call-next-method (&rest _args) + "Function to call the next applicable method. +Can only be used from within the lexical body of a primary or around method." + (error "cl-call-next-method only allowed inside primary and around methods")) + +;;; Add support for describe-function + +(add-hook 'help-fns-describe-function-functions 'cl--generic-describe) +(defun cl--generic-describe (function) + ;; FIXME: Fix up the main "in `'" hyperlink, and add such hyperlinks + ;; for each method. + (let ((generic (if (symbolp function) (cl--generic function)))) + (when generic + (save-excursion + (insert "\n\nThis is a generic function.\n\n") + (insert (propertize "Implementations:\n\n" 'face 'bold)) + ;; Loop over fanciful generics + (pcase-dolist (`((,type . ,qualifier) . ,method) + (cl--generic-method-table generic)) + (insert "`") + (if (symbolp type) + ;; FIXME: Add support for cl-structs in help-variable. + (help-insert-xref-button (symbol-name type) + 'help-variable type) + (insert (format "%S" type))) + (insert (format "' %S %S\n" + (car qualifier) + (let ((args (help-function-arglist method))) + ;; Drop cl--generic-next arg if present. + (if (memq (car qualifier) '(:after :before)) + args (cdr args))))) + (insert (or (documentation method) "Undocumented") "\n\n")))))) + +;;; Support for (eql ) specializers. + +(defvar cl--generic-eql-used (make-hash-table :test #'eql)) + +(add-function :before-until cl-generic-tagcode-function + #'cl--generic-eql-tagcode) +(defun cl--generic-eql-tagcode (type name) + (when (eq (car-safe type) 'eql) + (puthash (cadr type) type cl--generic-eql-used) + `(100 . (gethash ,name cl--generic-eql-used)))) + +(add-function :before-until cl-generic-tag-types-function + #'cl--generic-eql-tag-types) +(defun cl--generic-eql-tag-types (tag) + (if (eq (car-safe tag) 'eql) (list tag))) + +;;; Support for cl-defstructs specializers. + +(add-function :before-until cl-generic-tagcode-function + #'cl--generic-struct-tagcode) +(defun cl--generic-struct-tagcode (type name) + (and (symbolp type) + (get type 'cl-struct-type) + (or (eq 'vector (car (get type 'cl-struct-type))) + (error "Can't dispatch on cl-struct %S: type is %S" + type (car (get type 'cl-struct-type)))) + (or (equal '(cl-tag-slot) (car (get type 'cl-struct-slots))) + (error "Can't dispatch on cl-struct %S: no tag in slot 0" + type)) + ;; We could/should check the vector has length >0, + ;; but really, mixing vectors and structs is a bad idea, + ;; so let's not waste time trying to handle the case + ;; of an empty vector. + ;; BEWARE: this returns a bogus tag for non-struct vectors. + `(50 . (and (vectorp ,name) (aref ,name 0))))) + +(add-function :before-until cl-generic-tag-types-function + #'cl--generic-struct-tag-types) +(defun cl--generic-struct-tag-types (tag) + ;; FIXME: cl-defstruct doesn't make it easy for us. + (and (symbolp tag) + ;; A method call shouldn't itself mess with the match-data. + (string-match-p "\\`cl-struct-\\(.*\\)" (symbol-name tag)) + (let ((types (list (intern (substring (symbol-name tag) 10))))) + (while (get (car types) 'cl-struct-include) + (push (get (car types) 'cl-struct-include) types)) + (push 'cl-struct types) ;The "parent type" of all cl-structs. + (nreverse types)))) + +;;; Dispatch on "old-style types". + +(defconst cl--generic-typeof-types + ;; Hand made from the source code of `type-of'. + '((integer number) (symbol) (string array) (cons list) + ;; Markers aren't `numberp', yet they are accepted wherever integers are + ;; accepted, pretty much. + (marker) (overlay) (float number) (window-configuration) + (process) (window) (subr) (compiled-function) (buffer) (char-table array) + (bool-vector array) + (frame) (hash-table) (font-spec) (font-entity) (font-object) + (vector array) + ;; Plus, hand made: + (null list symbol) + (list) + (array) + (number))) + +(add-function :before-until cl-generic-tagcode-function + #'cl--generic-typeof-tagcode) +(defun cl--generic-typeof-tagcode (type name) + ;; FIXME: Add support for other types accepted by `cl-typep' such + ;; as `character', `atom', `face', `function', ... + (and (assq type cl--generic-typeof-types) + (progn + (if (memq type '(vector array)) + (message "`%S' also matches CL structs and EIEIO classes" type)) + ;; FIXME: We could also change `type-of' to return `null' for nil. + `(10 . (if ,name (type-of ,name) 'null))))) + +(add-function :before-until cl-generic-tag-types-function + #'cl--generic-typeof-types) +(defun cl--generic-typeof-types (tag) + (and (symbolp tag) + (assq tag cl--generic-typeof-types))) + +;;; Just for kicks: dispatch on major-mode +;; +;; Here's how you'd use it: +;; (cl-defmethod foo ((x (major-mode text-mode)) y z) ...) +;; And then +;; (foo 'major-mode toto titi) +;; +;; FIXME: Better would be to do that via dispatch on an "implicit argument". + +;; (defvar cl--generic-major-modes (make-hash-table :test #'eq)) +;; +;; (add-function :before-until cl-generic-tagcode-function +;; #'cl--generic-major-mode-tagcode) +;; (defun cl--generic-major-mode-tagcode (type name) +;; (if (eq 'major-mode (car-safe type)) +;; `(50 . (if (eq ,name 'major-mode) +;; (cl--generic-with-memoization +;; (gethash major-mode cl--generic-major-modes) +;; `(cl--generic-major-mode . ,major-mode)))))) +;; +;; (add-function :before-until cl-generic-tag-types-function +;; #'cl--generic-major-mode-types) +;; (defun cl--generic-major-mode-types (tag) +;; (when (eq (car-safe tag) 'cl--generic-major-mode) +;; (if (eq tag 'fundamental-mode) '(fundamental-mode t) +;; (let ((types `((major-mode ,(cdr tag))))) +;; (while (get (car types) 'derived-mode-parent) +;; (push (list 'major-mode (get (car types) 'derived-mode-parent)) +;; types)) +;; (unless (eq 'fundamental-mode (car types)) +;; (push '(major-mode fundamental-mode) types)) +;; (nreverse types))))) + +;; Local variables: +;; generated-autoload-file: "cl-loaddefs.el" +;; End: + +(provide 'cl-generic) +;;; cl-generic.el ends here diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index fff5b27315c..0070599af6f 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -625,14 +625,20 @@ The result of the body appears to the compiler as a quoted constant." (set `(setq ,temp ,form))) (if (and (fboundp 'byte-compile-file-form-defmumble) (boundp 'this-kind) (boundp 'that-one)) - (fset 'byte-compile-file-form - `(lambda (form) - (fset 'byte-compile-file-form - ',(symbol-function 'byte-compile-file-form)) - (byte-compile-file-form ',set) - (byte-compile-file-form form))) - (print set (symbol-value 'byte-compile--outbuffer))) - `(symbol-value ',temp)) + ;; Else, we can't output right away, so we have to delay it to the + ;; next time we're at the top-level. + ;; FIXME: Use advice-add/remove. + (fset 'byte-compile-file-form + (let ((old (symbol-function 'byte-compile-file-form))) + (lambda (form) + (fset 'byte-compile-file-form old) + (byte-compile-file-form set) + (byte-compile-file-form form)))) + ;; If we're not in the middle of compiling something, we can + ;; output directly to byte-compile-outbuffer, to make sure + ;; temp is set before we use it. + (print set byte-compile--outbuffer)) + temp) `',(eval form))) @@ -1824,18 +1830,30 @@ a `let' form, except that the list of symbols can be computed at run-time." (defmacro cl-flet (bindings &rest body) "Make local function definitions. Like `cl-labels' but the definitions are not recursive. +Each binding can take the form (FUNC EXP) where +FUNC is the function name, and EXP is an expression that returns the +function value to which it should be bound, or it can take the more common +form \(FUNC ARGLIST BODY...) which is a shorthand +for (FUNC (lambda ARGLIST BODY)). \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) (debug ((&rest (cl-defun)) cl-declarations body))) (let ((binds ()) (newenv macroexpand-all-environment)) (dolist (binding bindings) - (let ((var (make-symbol (format "--cl-%s--" (car binding))))) - (push (list var `(cl-function (lambda . ,(cdr binding)))) binds) + (let ((var (make-symbol (format "--cl-%s--" (car binding)))) + (args-and-body (cdr binding))) + (if (and (= (length args-and-body) 1) (symbolp (car args-and-body))) + ;; Optimize (cl-flet ((fun var)) body). + (setq var (car args-and-body)) + (push (list var (if (= (length args-and-body) 1) + (car args-and-body) + `(cl-function (lambda . ,args-and-body)))) + binds)) (push (cons (car binding) - `(lambda (&rest cl-labels-args) - (cl-list* 'funcall ',var - cl-labels-args))) + (lambda (&rest cl-labels-args) + (cl-list* 'funcall var cl-labels-args))) newenv))) + ;; FIXME: Eliminate those functions which aren't referenced. `(let ,(nreverse binds) ,@(macroexp-unprogn (macroexpand-all @@ -1869,9 +1887,8 @@ in closures will only work if `lexical-binding' is in use. (let ((var (make-symbol (format "--cl-%s--" (car binding))))) (push (list var `(cl-function (lambda . ,(cdr binding)))) binds) (push (cons (car binding) - `(lambda (&rest cl-labels-args) - (cl-list* 'funcall ',var - cl-labels-args))) + (lambda (&rest cl-labels-args) + (cl-list* 'funcall var cl-labels-args))) newenv))) (macroexpand-all `(letrec ,(nreverse binds) ,@body) ;; Don't override lexical-let's macro-expander. @@ -1898,7 +1915,8 @@ This is like `cl-flet', but for macros instead of functions. (res (cl--transform-lambda (cdar bindings) name))) (eval (car res)) (macroexpand-all (macroexp-progn body) - (cons (cons name `(lambda ,@(cdr res))) + (cons (cons name + (eval `(cl-function (lambda ,@(cdr res))) t)) macroexpand-all-environment)))))) (defconst cl--old-macroexpand diff --git a/test/ChangeLog b/test/ChangeLog index 83bb8bf00c7..211a06c2cbd 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,3 +1,7 @@ +2015-01-14 Stefan Monnier + + * automated/cl-generic-tests.el: New file. + 2015-01-08 Stefan Monnier * automated/eieio-tests.el (eieio-test-23-inheritance-check): Don't use diff --git a/test/automated/cl-generic-tests.el b/test/automated/cl-generic-tests.el new file mode 100644 index 00000000000..5c5e5d1c7ce --- /dev/null +++ b/test/automated/cl-generic-tests.el @@ -0,0 +1,131 @@ +;;; cl-generic-tests.el --- Tests for cl-generic.el functionality -*- lexical-binding: t; -*- + +;; Copyright (C) 2015 Stefan Monnier + +;; Author: Stefan Monnier + +;; 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: + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(cl-defgeneric cl--generic-1 (x y)) +(cl-defgeneric (setf cl--generic-1) (v y z) "My generic doc.") + +(ert-deftest cl-generic-test-0 () + (cl-defgeneric cl--generic-1 (x y)) + (cl-defmethod cl--generic-1 ((x t) y) (cons x y)) + (should (equal (cl--generic-1 'a 'b) '(a . b)))) + +(ert-deftest cl-generic-test-1-eql () + (cl-defgeneric cl--generic-1 (x y)) + (cl-defmethod cl--generic-1 ((x t) y) (cons x y)) + (cl-defmethod cl--generic-1 ((_x (eql 4)) _y) + (cons "quatre" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x (eql 5)) _y) + (cons "cinq" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x (eql 6)) y) + (cons "six" (cl-call-next-method 'a y))) + (should (equal (cl--generic-1 'a nil) '(a))) + (should (equal (cl--generic-1 4 nil) '("quatre" 4))) + (should (equal (cl--generic-1 5 nil) '("cinq" 5))) + (should (equal (cl--generic-1 6 nil) '("six" a)))) + +(cl-defstruct cl-generic-struct-parent a b) +(cl-defstruct (cl-generic-struct-child1 (:include cl-generic-struct-parent)) c) +(cl-defstruct (cl-generic-struct-child11 (:include cl-generic-struct-child1)) d) +(cl-defstruct (cl-generic-struct-child2 (:include cl-generic-struct-parent)) e) + +(ert-deftest cl-generic-test-2-struct () + (cl-defgeneric cl--generic-1 (x y) "My doc.") + (cl-defmethod cl--generic-1 ((x t) y) "Doc 1." (cons x y)) + (cl-defmethod cl--generic-1 ((_x cl-generic-struct-parent) y) + "Doc 2." (cons "parent" (cl-call-next-method 'a y))) + (cl-defmethod cl--generic-1 ((_x cl-generic-struct-child1) _y) + (cons "child1" (cl-call-next-method))) + (cl-defmethod cl--generic-1 :around ((_x t) _y) + (cons "around" (cl-call-next-method))) + (cl-defmethod cl--generic-1 :around ((_x cl-generic-struct-child11) _y) + (cons "child11" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x cl-generic-struct-child2) _y) + (cons "child2" (cl-call-next-method))) + (should (equal (cl--generic-1 (make-cl-generic-struct-child1) nil) + '("around" "child1" "parent" a))) + (should (equal (cl--generic-1 (make-cl-generic-struct-child2) nil) + '("around""child2" "parent" a))) + (should (equal (cl--generic-1 (make-cl-generic-struct-child11) nil) + '("child11" "around""child1" "parent" a)))) + +(ert-deftest cl-generic-test-3-setf () + (cl-defmethod (setf cl--generic-1) (v (y t) z) (list v y z)) + (cl-defmethod (setf cl--generic-1) (v (_y (eql 4)) z) (list v "four" z)) + (should (equal (setf (cl--generic-1 'a 'b) 'v) '(v a b))) + (should (equal (setf (cl--generic-1 4 'b) 'v) '(v "four" b))) + (let ((x ())) + (should (equal (setf (cl--generic-1 (progn (push 1 x) 'a) + (progn (push 2 x) 'b)) + (progn (push 3 x) 'v)) + '(v a b))) + (should (equal x '(3 2 1))))) + +(ert-deftest cl-generic-test-4-overlapping-tagcodes () + (cl-defgeneric cl--generic-1 (x y) "My doc.") + (cl-defmethod cl--generic-1 ((y t) z) (list y z)) + (cl-defmethod cl--generic-1 ((_y (eql 4)) _z) + (cons "four" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_y integer) _z) + (cons "integer" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_y number) _z) + (cons "number" (cl-call-next-method))) + (should (equal (cl--generic-1 'a 'b) '(a b))) + (should (equal (cl--generic-1 1 'b) '("integer" "number" 1 b))) + (should (equal (cl--generic-1 4 'b) '("four" "integer" "number" 4 b)))) + +(ert-deftest cl-generic-test-5-alias () + (cl-defgeneric cl--generic-1 (x y) "My doc.") + (defalias 'cl--generic-2 #'cl--generic-1) + (cl-defmethod cl--generic-1 ((y t) z) (list y z)) + (cl-defmethod cl--generic-2 ((_y (eql 4)) _z) + (cons "four" (cl-call-next-method))) + (should (equal (cl--generic-1 4 'b) '("four" 4 b)))) + +(ert-deftest cl-generic-test-6-multiple-dispatch () + (cl-defgeneric cl--generic-1 (x y) "My doc.") + (cl-defmethod cl--generic-1 (x y) (list x y)) + (cl-defmethod cl--generic-1 (_x (_y integer)) + (cons "y-int" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x integer) _y) + (cons "x-int" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x integer) (_y integer)) + (cons "x&y-int" (cl-call-next-method))) + (should (equal (cl--generic-1 1 2) '("x&y-int" "x-int" "y-int" 1 2)))) + +(ert-deftest cl-generic-test-7-apo () + (cl-defgeneric cl--generic-1 (x y) + (:documentation "My doc.") (:argument-precedence-order y x)) + (cl-defmethod cl--generic-1 (x y) (list x y)) + (cl-defmethod cl--generic-1 (_x (_y integer)) + (cons "y-int" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x integer) _y) + (cons "x-int" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x integer) (_y integer)) + (cons "x&y-int" (cl-call-next-method))) + (should (equal (cl--generic-1 1 2) '("x&y-int" "y-int" "x-int" 1 2)))) + +(provide 'cl-generic-tests) +;;; cl-generic-tests.el ends here