1 ;;; gfunc.el --- support for generic function
2 ;;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2015, 2016, 2017
3 ;;; HIRAOKA Kazuyuki <khi@users.sourceforge.jp>
4 ;;; $Id: gfunc.el,v 1.16 2011-12-31 15:07:29 hira Exp $
6 ;;; This program is free software; you can redistribute it and/or modify
7 ;;; it under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 1, or (at your option)
11 ;;; This program is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU General Public License for more details.
16 ;;; The GNU General Public License is available by anonymouse ftp from
17 ;;; prep.ai.mit.edu in pub/gnu/COPYING. Alternately, you can write to
18 ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139,
20 ;;;--------------------------------------------------------------------
24 ;; (defun less-than:num (x y)
26 ;; (defun less-than:str (x y)
28 ;; (defun type-of (x y)
29 ;; (cond ((numberp x) ':num)
30 ;; ((stringp x) ':str)))
31 ;; (defvar disp-list (list #'type-of))
32 ;; (gfunc-define-function less-than (x y) disp-list) ;; --- <*>
33 ;; (less-than 3 8) ;; (less-than:num 3 8) ==> t
34 ;; (less-than "xyz" "abc") ;; (less-than:str "xyz" "abc") ==> nil
35 ;; (pp (macroexpand '(gfunc-def less-than (x y) disp-list)))
37 ;; ;; This is equivalent to above <*>.
38 ;; (gfunc-with disp-list
39 ;; (gfunc-def less-than (x y))
40 ;; ;; You can insert more methods here. For example...
41 ;; ;; (less-or-equal (x y))
42 ;; ;; (more-than (x y))
45 (defvar *gfunc-dispatchers-var* nil
47 (put '*gfunc-dispatchers-var* 'risky-local-variable t)
50 (defun gfunc-call (base-name dispatchers args)
54 (setq type (apply (car dispatchers) args))
57 (apply (intern-soft (format "%s%s" base-name type))
59 (setq dispatchers (cdr dispatchers))))
60 (error "Can't detect type of %s for %s." args base-name))))
62 ;; (defun gfunc-call (base-name dispatchers args)
63 ;; (if (null dispatchers)
64 ;; (error "Can't detect type of %s for %s." args base-name)
65 ;; (let ((type (apply (car dispatchers) args)))
67 ;; (gfunc-call base-name (cdr dispatchers) args)
68 ;; (let ((f (intern-soft (format "%s%s" base-name type))))
69 ;; (apply f args))))))
71 ;; (put 'gfunc-def 'lisp-indent-hook 2)
72 (defmacro gfunc-define-function (base-name args-declaration dispatchers-var
73 &optional description)
74 "Define generic function.
75 BASE-NAME is name of generic function.
76 ARGS-DECLARATION has no effect; it is merely note for programmers.
77 DISPATCHERS-VAR is name of variable whose value is list of type-detectors.
78 Type-detector receives arguments to the function BASE-NAME, and returns
80 Then, BASE-NAME + type is the name of real function.
81 Type detector must return nil if it cannot determine the type, so that
82 the task is chained to next detector."
83 (let ((desc-str (format "%s
87 Internally, %s___ is called according to the type of ARGS.
88 The type part ___ is determined by functions in the list `%s'.
89 This function is generated by `gfunc-define-function'."
90 (or description "Generic function.")
94 `(defun ,base-name (&rest args)
96 (gfunc-call (quote ,base-name) ,dispatchers-var args))))
98 (defmacro gfunc-def (base-name args-declaration &optional description)
99 "Define generic function like `gfunc-define-function'.
100 The only difference is omission of dispatchers; it must be specified
101 by `gfunc-with' outside."
103 `(gfunc-define-function ,base-name ,args-declaration ,*gfunc-dispatchers-var*
106 (defmacro gfunc-with (dispatchers-var &rest body)
107 "With the defalut DISPATCHERS-VAR, execute BODY.
108 BODY is typically a set of `gfunc-def', and DISPATCHERS-VAR is used
109 as their dispatchers.
110 This macro cannot be nested."
112 ;; Be careful to etc/NEWS in Emacs 24.3 or
113 ;; http://www.masteringemacs.org/articles/2013/03/11/whats-new-emacs-24-3/
114 ;; "Emacs tries to macroexpand interpreted (non-compiled) files during load."
115 (setq *gfunc-dispatchers-var* dispatchers-var)
121 ;;; gfunc.el ends here