File: gfunc.el

package info (click to toggle)
howm 1.4.4-3
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 2,708 kB
  • sloc: lisp: 7,770; sh: 3,408; ruby: 996; makefile: 96
file content (121 lines) | stat: -rw-r--r-- 4,789 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
;;; gfunc.el --- support for generic function
;;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2015, 2016
;;;   HIRAOKA Kazuyuki <khi@users.sourceforge.jp>
;;; $Id: gfunc.el,v 1.16 2011-12-31 15:07:29 hira Exp $
;;;
;;; 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 1, 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.
;;;
;;; The GNU General Public License is available by anonymouse ftp from
;;; prep.ai.mit.edu in pub/gnu/COPYING.  Alternately, you can write to
;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139,
;;; USA.
;;;--------------------------------------------------------------------

;; sample
;; 
;; (defun less-than:num (x y)
;;   (< x y))
;; (defun less-than:str (x y)
;;   (string< x y))
;; (defun type-of (x y)
;;   (cond ((numberp x) ':num)
;;         ((stringp x) ':str)))
;; (defvar disp-list (list #'type-of))
;; (gfunc-define-function less-than (x y) disp-list)  ;; --- <*>
;; (less-than 3 8)          ;; (less-than:num 3 8)         ==> t
;; (less-than "xyz" "abc")  ;; (less-than:str "xyz" "abc") ==> nil
;; (pp (macroexpand '(gfunc-def less-than (x y) disp-list)))
;; 
;; ;; This is equivalent to above <*>.
;; (gfunc-with disp-list
;;   (gfunc-def less-than (x y))
;;   ;; You can insert more methods here. For example...
;;   ;; (less-or-equal (x y))
;;   ;; (more-than (x y))
;;   )

(defvar *gfunc-dispatchers-var* nil
  "For internal use")
(put '*gfunc-dispatchers-var* 'risky-local-variable t)

;; loop version
(defun gfunc-call (base-name dispatchers args)
  (let (type)
    (catch 'done
      (while dispatchers
        (setq type (apply (car dispatchers) args))
        (if type
            (throw 'done
                   (apply (intern-soft (format "%s%s" base-name type))
                          args))
          (setq dispatchers (cdr dispatchers))))
      (error "Can't detect type of %s for %s." args base-name))))

;; (defun gfunc-call (base-name dispatchers args)
;;   (if (null dispatchers)
;;       (error "Can't detect type of %s for %s." args base-name)
;;     (let ((type (apply (car dispatchers) args)))
;;       (if (null type)
;;           (gfunc-call base-name (cdr dispatchers) args)
;;         (let ((f (intern-soft (format "%s%s" base-name type))))
;;           (apply f args))))))

;; (put 'gfunc-def 'lisp-indent-hook 2)
(defmacro gfunc-define-function (base-name args-declaration dispatchers-var
                                           &optional description)
  "Define generic function.
BASE-NAME is name of generic function.
ARGS-DECLARATION has no effect; it is merely note for programmers.
DISPATCHERS-VAR is name of variable whose value is list of type-detectors.
Type-detector receives arguments to the function BASE-NAME, and returns
its 'type' symbol.
Then, BASE-NAME + type is the name of real function.
Type detector must return nil if it cannot determine the type, so that
the task is chained to next detector."
  (let ((desc-str (format "%s

ARGS = %s

Internally, %s___ is called according to the type of ARGS.
The type part ___ is determined by functions in the list `%s'.
This function is generated by `gfunc-define-function'."
                          (or description "Generic function.")
                          args-declaration
                          base-name
                          dispatchers-var)))
    `(defun ,base-name (&rest args)
       ,desc-str
       (gfunc-call (quote ,base-name) ,dispatchers-var args))))

(defmacro gfunc-def (base-name args-declaration &optional description)
  "Define generic function like `gfunc-define-function'.
The only difference is omission of dispatchers; it must be specified
by `gfunc-with' outside."
  (declare (indent 2))
  `(gfunc-define-function ,base-name ,args-declaration ,*gfunc-dispatchers-var*
                          ,description))

(defmacro gfunc-with (dispatchers-var &rest body)
  "With the defalut DISPATCHERS-VAR, execute BODY.
BODY is typically a set of `gfunc-def', and DISPATCHERS-VAR is used
as their dispatchers.
This macro cannot be nested."
  (declare (indent 1))
  ;; Be careful to etc/NEWS in Emacs 24.3 or
  ;; http://www.masteringemacs.org/articles/2013/03/11/whats-new-emacs-24-3/
  ;; "Emacs tries to macroexpand interpreted (non-compiled) files during load."
  (setq *gfunc-dispatchers-var* dispatchers-var)
  `(eval-and-compile
     ,@body))

(provide 'gfunc)

;;; gfunc.el ends here