gfunc.el

   1 ;;; gfunc.el --- support for generic function
   2 ;;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2015, 2016
   3 ;;;   HIRAOKA Kazuyuki <khi@users.sourceforge.jp>
   4 ;;; $Id: gfunc.el,v 1.16 2011-12-31 15:07:29 hira Exp $
   5 ;;;
   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)
   9 ;;; any later version.
  10 ;;;
  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.
  15 ;;;
  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,
  19 ;;; USA.
  20 ;;;--------------------------------------------------------------------
  21
  22 ;; sample
  23 ;;
  24 ;; (defun less-than:num (x y)
  25 ;;   (< x y))
  26 ;; (defun less-than:str (x y)
  27 ;;   (string< 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)))
  36 ;;
  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))
  43 ;;   )
  44
  45 (defvar *gfunc-dispatchers-var* nil
  46   "For internal use")
  47 (put '*gfunc-dispatchers-var* 'risky-local-variable t)
  48
  49 ;; loop version
  50 (defun gfunc-call (base-name dispatchers args)
  51   (let (type)
  52     (catch 'done
  53       (while dispatchers
  54         (setq type (apply (car dispatchers) args))
  55         (if type
  56             (throw 'done
  57                    (apply (intern-soft (format "%s%s" base-name type))
  58                           args))
  59           (setq dispatchers (cdr dispatchers))))
  60       (error "Can't detect type of %s for %s." args base-name))))
  61
  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)))
  66 ;;       (if (null type)
  67 ;;           (gfunc-call base-name (cdr dispatchers) args)
  68 ;;         (let ((f (intern-soft (format "%s%s" base-name type))))
  69 ;;           (apply f args))))))
  70
  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
  79 its 'type' symbol.
  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
  84
  85 ARGS = %s
  86
  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.")
  91                           args-declaration
  92                           base-name
  93                           dispatchers-var)))
  94     `(defun ,base-name (&rest args)
  95        ,desc-str
  96        (gfunc-call (quote ,base-name) ,dispatchers-var args))))
  97
  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."
 102   (declare (indent 2))
 103   `(gfunc-define-function ,base-name ,args-declaration ,*gfunc-dispatchers-var*
 104                           ,description))
 105
 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."
 111   (declare (indent 1))
 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)
 116   `(eval-and-compile
 117      ,@body))
 118
 119 (provide 'gfunc)
 120
 121 ;;; gfunc.el ends here