2000-08-23 Yuuichi Teranishi <teranisi@gohome.org>

[elisp/flim.git] / luna.el

diff --git a/luna.el b/luna.el
index 2de07af..e66d265 100644 (file)
--- a/luna.el
+++ b/luna.el
@@ -27,6 +27,15 @@
 
 (eval-when-compile (require 'cl))
 
+(eval-when-compile (require 'static))
+
+(static-condition-case nil
+    :symbol-for-testing-whether-colon-keyword-is-available-or-not
+  (void-variable
+   (defconst :before ':before)
+   (defconst :after ':after)
+   (defconst :around ':around)))
+
 (defmacro luna-find-class (name)
   "Return the luna-class of the given NAME."
   `(get ,name 'luna-class))
@@ -52,6 +61,13 @@ If SLOTS is specified, TYPE will be defined to have them."
                               ',slots))
 
 (defun luna-define-class-function (type &optional parents slots)
+  (static-condition-case nil
+      :symbol-for-testing-whether-colon-keyword-is-available-or-not
+    (void-variable
+     (let (key)
+       (dolist (slot slots)
+        (setq key (intern (format ":%s" slot)))
+        (set key key)))))
   (let ((oa (make-vector 31 0))
        (rest parents)
        parent name
@@ -121,18 +137,19 @@ Usage of this macro follows:
 
 NAME is the name of method.
 
-Optional argument METHOD-QUALIFIER must be :after.  If it is :after,
-the method is called after a method of parent class is finished.
-ARGLIST is like an argument list of lambda, but (car ARGLIST) must be
-specialized parameter.  (car (car ARGLIST)) is name of variable and
-\(nth 1 (car ARGLIST)) is name of class.
+Optional argument METHOD-QUALIFIER must be :before, :after or :around.
+If it is :before / :after, the method is called before / after a
+method of parent class is finished.  ARGLIST is like an argument list
+of lambda, but (car ARGLIST) must be specialized parameter.  (car (car
+ARGLIST)) is name of variable and \(nth 1 (car ARGLIST)) is name of
+class.
 
 Optional argument DOCSTRING is the documentation of method.
 
 BODY is the body of method."
   (let ((method-qualifier (pop definition))
        args specializer class self)
-    (if (eq method-qualifier :after)
+    (if (memq method-qualifier '(:before :after :around))
        (setq args (pop definition))
       (setq args method-qualifier
            method-qualifier nil)
@@ -153,7 +170,7 @@ BODY is the body of method."
 (put 'luna-define-method 'lisp-indent-function 'defun)
 
 (def-edebug-spec luna-define-method
-  (&define name [&optional ":after"]
+  (&define name [&optional &or ":before" ":after" ":around"]
           ((arg symbolp)
            [&rest arg]
            [&optional ["&optional" arg &rest arg]]
@@ -174,11 +191,20 @@ BODY is the body of method."
 (defun luna-class-find-functions (class service)
   (let ((sym (luna-class-find-member class service)))
     (if (fboundp sym)
-       (if (eq (get sym 'luna-method-qualifier) :after)
-           (nconc (luna-class-find-parents-functions class service)
-                  (list (symbol-function sym)))
-         (list (symbol-function sym))
-         )
+       (cond ((eq (get sym 'luna-method-qualifier) :before)
+              (cons (symbol-function sym)
+                    (luna-class-find-parents-functions class service))
+              )
+             ((eq (get sym 'luna-method-qualifier) :after)
+              (nconc (luna-class-find-parents-functions class service)
+                     (list (symbol-function sym)))
+              )
+             ((eq (get sym 'luna-method-qualifier) :around)
+              (cons sym (luna-class-find-parents-functions class service))
+              )
+             (t
+              (list (symbol-function sym))
+              ))
       (luna-class-find-parents-functions class service)
       )))
 
@@ -186,15 +212,44 @@ BODY is the body of method."
   `(luna-class-find-functions (luna-find-class (luna-class-name ,entity))
                              ,service))
 
-(defsubst luna-send (entity message &rest args)
-  "Send MESSAGE to ENTITY with ARGS, and return the result."
-  (let ((functions (luna-find-functions entity message))
-       ret)
-    (while functions
-      (setq ret (apply (car functions) args)
-           functions (cdr functions))
-      )
-    ret))
+(defsubst luna-send (entity message &rest luna-current-method-arguments)
+  "Send MESSAGE to ENTITY, and return the result.
+LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE."
+  (let ((luna-next-methods (luna-find-functions entity message))
+       luna-current-method
+       luna-previous-return-value)
+    (while (and luna-next-methods
+               (progn
+                 (setq luna-current-method (pop luna-next-methods)
+                       luna-previous-return-value
+                       (apply luna-current-method
+                              luna-current-method-arguments))
+                 (if (symbolp luna-current-method)
+                     (not (eq (get luna-current-method
+                                   'luna-method-qualifier) :around))
+                   t))))
+    luna-previous-return-value))
+
+(eval-when-compile
+  (defvar luna-next-methods nil)
+  (defvar luna-current-method-arguments nil)
+  )
+
+(defun luna-call-next-method ()
+  "Call the next method in a method with :around qualifier."
+  (let (luna-current-method
+       luna-previous-return-value)
+    (while (and luna-next-methods
+               (progn
+                 (setq luna-current-method (pop luna-next-methods)
+                       luna-previous-return-value
+                       (apply luna-current-method
+                              luna-current-method-arguments))
+                 (if (symbolp luna-current-method)
+                     (not (eq (get luna-current-method
+                                   'luna-method-qualifier) :around))
+                   t))))
+    luna-previous-return-value))
 
 (defmacro luna-class-name (entity)
   "Return class-name of the ENTITY."