gfunc.el

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