;;; cl-generic.el --- CLOS-style generic functions for Elisp -*- lexical-binding: t; -*-
-;; Copyright (C) 2015 Free Software Foundation, Inc.
+;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Version: 1.0
;; TODO:
;;
-;; - A generic "filter" generalizer (e.g. could be used to cleanly adds methods
+;; - A generic "filter" generalizer (e.g. could be used to cleanly add methods
;; to cl-generic-combine-methods with a specializer that says it applies only
;; when some particular qualifier is used).
-;; - A way to dispatch on the context (e.g. the major-mode, some global
-;; variable, you name it).
;;; Code:
(cl-defstruct (cl--generic-generalizer
(:constructor nil)
(:constructor cl-generic-make-generalizer
- (priority tagcode-function specializers-function)))
+ (name priority tagcode-function specializers-function)))
+ (name nil :type string)
(priority nil :type integer)
tagcode-function
specializers-function)
-(defconst cl--generic-t-generalizer
- (cl-generic-make-generalizer
- 0 (lambda (_name) nil) (lambda (_tag) '(t))))
+
+(defmacro cl-generic-define-generalizer
+ (name priority tagcode-function specializers-function)
+ "Define a new kind of generalizer.
+NAME is the name of the variable that will hold it.
+PRIORITY defines which generalizer takes precedence.
+ The catch-all generalizer has priority 0.
+ Then `eql' generalizer has priority 100.
+TAGCODE-FUNCTION takes as first argument a varname and should return
+ a chunk of code that computes the tag of the value held in that variable.
+ Further arguments are reserved for future use.
+SPECIALIZERS-FUNCTION takes as first argument a tag value TAG
+ and should return a list of specializers that match TAG.
+ Further arguments are reserved for future use."
+ (declare (indent 1) (debug (symbolp body)))
+ `(defconst ,name
+ (cl-generic-make-generalizer
+ ',name ,priority ,tagcode-function ,specializers-function)))
+
+(cl-generic-define-generalizer cl--generic-t-generalizer
+ 0 (lambda (_name &rest _) nil) (lambda (_tag &rest _) '(t)))
(cl-defstruct (cl--generic-method
(:constructor nil)
(defmacro cl--generic (name)
`(get ,name 'cl--generic))
-(defun cl-generic-ensure-function (name)
+(defun cl-generic-ensure-function (name &optional noerror)
(let (generic
(origname name))
(while (and (null (setq generic (cl--generic name)))
(fboundp name)
+ (null noerror)
(symbolp (symbol-function name)))
(setq name (symbol-function name)))
(unless (or (not (fboundp name))
(autoloadp (symbol-function name))
- (and (functionp name) generic))
+ (and (functionp name) generic)
+ noerror)
(error "%s is already defined as something else than a generic function"
origname))
(if generic
- (declare DECLARATIONS)
- (:argument-precedence-order &rest ARGS)
- (:method [QUALIFIERS...] ARGS &rest BODY)
-BODY, if present, is used as the body of a default method.
+DEFAULT-BODY, if present, is used as the body of a default method.
-\(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest BODY)"
+\(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest DEFAULT-BODY)"
(declare (indent 2) (doc-string 3))
(let* ((doc (if (stringp (car-safe options-and-methods))
(pop options-and-methods)))
;;;###autoload
(defun cl-generic-define (name args options)
- (pcase-let* ((generic (cl-generic-ensure-function name))
+ (pcase-let* ((generic (cl-generic-ensure-function name 'noerror))
(`(,spec-args . ,_) (cl--generic-split-args args))
(mandatory (mapcar #'car spec-args))
(apo (assq :argument-precedence-order options)))
This macro can only be used within the lexical scope of a cl-generic method."
(error "cl-generic-current-method-specializers used outside of a method"))
+(defmacro cl-generic-define-context-rewriter (name args &rest body)
+ "Define a special kind of context named NAME.
+Whenever a context specializer of the form (NAME . ARGS) appears,
+the specializer used will be the one returned by BODY."
+ (declare (debug (&define name lambda-list def-body)) (indent defun))
+ `(eval-and-compile
+ (put ',name 'cl-generic--context-rewriter
+ (lambda ,args ,@body))))
+
(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 'context mandatory)
(unless (consp arg)
(error "Invalid &context arg: %S" arg))
+ (let* ((name (car arg))
+ (rewriter
+ (and (symbolp name)
+ (get name 'cl-generic--context-rewriter))))
+ (if rewriter (setq arg (apply rewriter (cdr arg)))))
(push `((&context . ,(car arg)) . ,(cadr arg)) specializers)
nil)
(`(,name . ,type)
(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
+values of the dispatch arguments match the specified TYPEs.
+The dispatch arguments have to be among the mandatory arguments, and
+all methods of NAME have to use the same set of arguments for dispatch.
+Each 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
: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.
+TYPE can be one of the basic types (see the full list and their
+hierarchy in `cl--generic-typeof-types'), CL struct type, or an
+EIEIO class.
+
+Other than that, TYPE can also be of the form `(eql VAL)' in
+which case this method will be invoked when the argument is `eql'
+to VAL, or `(head VAL)', in which case the argument is required
+to be a cons with VAL as its head.
\(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)"
(declare (doc-string 3) (indent 2)
;; function, so warnings like "not known to be defined" are fair game.
;; But in practice, it's common to use `cl-defmethod'
;; without a previous `cl-defgeneric'.
- (declare-function ,name "")
+ ;; The ",'" is a no-op that pacifies check-declare.
+ (,'declare-function ,name "")
(cl-generic-define-method ',name ',(nreverse qualifiers) ',args
,uses-cnm ,fun)))))
(setq i (1+ i))))
;; We used to (setcar me method), but that can cause false positives in
;; the hash-consing table of the method-builder (bug#20644).
- ;; See the related FIXME in cl--generic-build-combined-method.
- (setf (cl--generic-method-table generic) (cons method (delq (car me) mt)))
+ ;; See also the related FIXME in cl--generic-build-combined-method.
+ (setf (cl--generic-method-table generic)
+ (if (null me)
+ (cons method mt)
+ ;; Keep the ordering; important for methods with :extra qualifiers.
+ (mapcar (lambda (x) (if (eq x (car me)) method x)) mt)))
(cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers))
current-load-list :test #'equal)
;; FIXME: Try to avoid re-constructing a new function if the old one
(setq fun (cl-generic-call-method generic method fun)))
fun)))))
+(defun cl--generic-arg-specializer (method dispatch-arg)
+ (or (if (integerp dispatch-arg)
+ (nth dispatch-arg
+ (cl--generic-method-specializers method))
+ (cdr (assoc dispatch-arg
+ (cl--generic-method-specializers method))))
+ t))
+
(defun cl--generic-cache-miss (generic
dispatch-arg dispatches-left methods-left types)
(let ((methods '()))
(dolist (method methods-left)
- (let* ((specializer (or (if (integerp dispatch-arg)
- (nth dispatch-arg
- (cl--generic-method-specializers method))
- (cdr (assoc dispatch-arg
- (cl--generic-method-specializers method))))
- t))
+ (let* ((specializer (cl--generic-arg-specializer method dispatch-arg))
(m (member specializer types)))
(when m
(push (cons (length m) method) methods))))
The function can use `cl-generic-call-method' to create functions that call those
methods.")
-;; Temporary definition to let the next defmethod succeed.
-(fset 'cl-generic-generalizers
- (lambda (_specializer) (list cl--generic-t-generalizer)))
-(fset 'cl-generic-combine-methods #'cl--generic-standard-method-combination)
+(unless (ignore-errors (cl-generic-generalizers t))
+ ;; Temporary definition to let the next defmethod succeed.
+ (fset 'cl-generic-generalizers
+ (lambda (specializer)
+ (if (eq t specializer) (list cl--generic-t-generalizer))))
+ (fset 'cl-generic-combine-methods #'cl--generic-standard-method-combination))
(cl-defmethod cl-generic-generalizers (specializer)
"Support for the catch-all t specializer."
;;; 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-primary-method "No primary method for %S" 'cl-no-method)
-(define-error 'cl-no-applicable-method "No applicable method for %S"
+(define-error 'cl-no-method "No method")
+(define-error 'cl-no-next-method "No next method" 'cl-no-method)
+(define-error 'cl-no-primary-method "No primary method" 'cl-no-method)
+(define-error 'cl-no-applicable-method "No applicable method"
'cl-no-method)
(cl-defgeneric cl-no-next-method (generic method &rest args)
(setq applies t)))
applies))
-(defun cl--generic-all-functions (&optional type)
+(defun cl-generic-all-functions (&optional type)
"Return a list of all generic functions.
Optional TYPE argument returns only those functions that contain
methods for TYPE."
(defvar cl--generic-head-used (make-hash-table :test #'eql))
-(defconst cl--generic-head-generalizer
- (cl-generic-make-generalizer
- 80 (lambda (name) `(gethash (car-safe ,name) cl--generic-head-used))
- (lambda (tag) (if (eq (car-safe tag) 'head) (list tag)))))
+(cl-generic-define-generalizer cl--generic-head-generalizer
+ 80 (lambda (name &rest _) `(gethash (car-safe ,name) cl--generic-head-used))
+ (lambda (tag &rest _) (if (eq (car-safe tag) 'head) (list tag))))
(cl-defmethod cl-generic-generalizers :extra "head" (specializer)
"Support for the `(head VAL)' specializers."
(defvar cl--generic-eql-used (make-hash-table :test #'eql))
-(defconst cl--generic-eql-generalizer
- (cl-generic-make-generalizer
- 100 (lambda (name) `(gethash ,name cl--generic-eql-used))
- (lambda (tag) (if (eq (car-safe tag) 'eql) (list tag)))))
+(cl-generic-define-generalizer cl--generic-eql-generalizer
+ 100 (lambda (name &rest _) `(gethash ,name cl--generic-eql-used))
+ (lambda (tag &rest _) (if (eq (car-safe tag) 'eql) (list tag))))
(cl-defmethod cl-generic-generalizers ((specializer (head eql)))
"Support for the `(eql VAL)' specializers."
(cl--generic-prefill-dispatchers 0 (eql nil))
(cl--generic-prefill-dispatchers window-system (eql nil))
+(cl--generic-prefill-dispatchers (terminal-parameter nil 'xterm--get-selection)
+ (eql nil))
+(cl--generic-prefill-dispatchers (terminal-parameter nil 'xterm--set-selection)
+ (eql nil))
;;; Support for cl-defstructs specializers.
-(defun cl--generic-struct-tag (name)
+(defun cl--generic-struct-tag (name &rest _)
;; It's tempting to use (and (vectorp ,name) (aref ,name 0))
;; but that would suffer from some problems:
;; - the vector may have size 0.
(cl--class-parents class)))))
(nreverse parents)))
-(defun cl--generic-struct-specializers (tag)
+(defun cl--generic-struct-specializers (tag &rest _)
(and (symbolp tag) (boundp tag)
(let ((class (symbol-value tag)))
(when (cl-typep class 'cl-structure-class)
(cl--generic-class-parents class)))))
-(defconst cl--generic-struct-generalizer
- (cl-generic-make-generalizer
- 50 #'cl--generic-struct-tag
- #'cl--generic-struct-specializers))
+(cl-generic-define-generalizer cl--generic-struct-generalizer
+ 50 #'cl--generic-struct-tag
+ #'cl--generic-struct-specializers)
(cl-defmethod cl-generic-generalizers :extra "cl-struct" (type)
"Support for dispatch on cl-struct types."
(sequence)
(number)))
-(defconst cl--generic-typeof-generalizer
- (cl-generic-make-generalizer
- ;; FIXME: We could also change `type-of' to return `null' for nil.
- 10 (lambda (name) `(if ,name (type-of ,name) 'null))
- (lambda (tag) (and (symbolp tag) (assq tag cl--generic-typeof-types)))))
+(cl-generic-define-generalizer cl--generic-typeof-generalizer
+ ;; FIXME: We could also change `type-of' to return `null' for nil.
+ 10 (lambda (name &rest _) `(if ,name (type-of ,name) 'null))
+ (lambda (tag &rest _)
+ (and (symbolp tag) (assq tag cl--generic-typeof-types))))
(cl-defmethod cl-generic-generalizers :extra "typeof" (type)
"Support for dispatch on builtin types."
(or
(and (assq type cl--generic-typeof-types)
(progn
- (if (memq type '(vector array sequence))
- (message "`%S' also matches CL structs and EIEIO classes" type))
+ ;; FIXME: While this wrinkle in the semantics can be occasionally
+ ;; problematic, this warning is more often annoying than helpful.
+ ;;(if (memq type '(vector array sequence))
+ ;; (message "`%S' also matches CL structs and EIEIO classes"
+ ;; type))
(list cl--generic-typeof-generalizer)))
(cl-call-next-method)))
(cl--generic-prefill-dispatchers 0 integer)
+;;; Dispatch on major mode.
+
+;; Two parts:
+;; - first define a specializer (derived-mode <mode>) to match symbols
+;; representing major modes, while obeying the major mode hierarchy.
+;; - then define a context-rewriter so you can write
+;; "&context (major-mode c-mode)" rather than
+;; "&context (major-mode (derived-mode c-mode))".
+
+(defun cl--generic-derived-specializers (mode &rest _)
+ ;; FIXME: Handle (derived-mode <mode1> ... <modeN>)
+ (let ((specializers ()))
+ (while mode
+ (push `(derived-mode ,mode) specializers)
+ (setq mode (get mode 'derived-mode-parent)))
+ (nreverse specializers)))
+
+(cl-generic-define-generalizer cl--generic-derived-generalizer
+ 90 (lambda (name) `(and (symbolp ,name) (functionp ,name) ,name))
+ #'cl--generic-derived-specializers)
+
+(cl-defmethod cl-generic-generalizers ((_specializer (head derived-mode)))
+ "Support for the `(derived-mode MODE)' specializers."
+ (list cl--generic-derived-generalizer))
+
+(cl-generic-define-context-rewriter major-mode (mode &rest modes)
+ `(major-mode ,(if (consp mode)
+ ;;E.g. could be (eql ...)
+ (progn (cl-assert (null modes)) mode)
+ `(derived-mode ,mode . ,modes))))
+
;; Local variables:
;; generated-autoload-file: "cl-loaddefs.el"
;; End: