X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=luna.el;h=f3504a6bc15b33746f96f45733dde7f355c07658;hb=0f0317cf179760a10043565f80f31853a6161bff;hp=8f2c64f003d29d9dd877ae4ea24a7612bbf3e03a;hpb=9e542a831d40a00b08c7fedb519d472ba79f1a7a;p=elisp%2Fflim.git

diff --git a/luna.el b/luna.el
index 8f2c64f..f3504a6 100644
--- a/luna.el
+++ b/luna.el
@@ -27,31 +27,48 @@
 
 (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))
+  (` (get (, name) 'luna-class)))
 
 (defmacro luna-set-class (name class)
-  `(put ,name 'luna-class ,class))
+  (` (put (, name) 'luna-class (, class))))
 
 (defmacro luna-class-obarray (class)
-  `(aref ,class 1))
+  (` (aref (, class) 1)))
 
 (defmacro luna-class-parents (class)
-  `(aref ,class 2))
+  (` (aref (, class) 2)))
 
 (defmacro luna-class-number-of-slots (class)
-  `(aref ,class 3))
+  (` (aref (, class) 3)))
 
 (defmacro luna-define-class (type &optional parents slots)
   "Define TYPE as a luna-class.
 If PARENTS is specified, TYPE inherits PARENTS.
 Each parent must be name of luna-class (symbol).
 If SLOTS is specified, TYPE will be defined to have them."
-  `(luna-define-class-function ',type ',(append parents '(standard-object))
-			       ',slots))
+  (` (luna-define-class-function '(, type)
+				 '(, (append parents '(standard-object)))
+				 '(, 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
@@ -60,13 +77,14 @@ If SLOTS is specified, TYPE will be defined to have them."
     (while rest
       (setq parent (pop rest)
 	    b (- i 2))
-      (mapatoms (lambda (sym)
-		  (when (setq j (get sym 'luna-slot-index))
-		    (setq name (symbol-name sym))
-		    (unless (intern-soft name oa)
-		      (put (intern name oa) 'luna-slot-index (+ j b))
-		      (setq i (1+ i))
-		      )))
+      (mapatoms (function
+		 (lambda (sym)
+		   (when (setq j (get sym 'luna-slot-index))
+		     (setq name (symbol-name sym))
+		     (unless (intern-soft name oa)
+		       (put (intern name oa) 'luna-slot-index (+ j b))
+		       (setq i (1+ i))
+		       ))))
 		(luna-class-obarray (luna-find-class parent)))
       )
     (setq rest slots)
@@ -98,11 +116,11 @@ If SLOTS is specified, TYPE will be defined to have them."
   (intern member-name (luna-class-obarray class)))
 
 (defmacro luna-class-slot-index (class slot-name)
-  `(get (luna-class-find-member ,class ,slot-name) 'luna-slot-index))
+  (` (get (luna-class-find-member (, class) (, slot-name)) 'luna-slot-index)))
 
 (defmacro luna-slot-index (entity slot-name)
-  `(luna-class-slot-index (luna-find-class (luna-class-name ,entity))
-			  ,slot-name))
+  (` (luna-class-slot-index (luna-find-class (luna-class-name (, entity)))
+			    (, slot-name))))
 
 (defsubst luna-slot-value (entity slot)
   "Return the value of SLOT of ENTITY."
@@ -121,18 +139,19 @@ Usage of this macro follows:
 
 NAME is the name of method.
 
-Optional argument METHOD-QUALIFIER must be :before or :after.  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 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 (memq method-qualifier '(:before :after))
+    (if (memq method-qualifier '(:before :after :around))
 	(setq args (pop definition))
       (setq args method-qualifier
 	    method-qualifier nil)
@@ -140,20 +159,22 @@ BODY is the body of method."
     (setq specializer (car args)
 	  class (nth 1 specializer)
 	  self (car specializer))
-    `(let ((func (lambda ,(if self
-			      (cons self (cdr args))
-			    (cdr args))
-		   ,@definition))
-	   (sym (luna-class-find-or-make-member
-		 (luna-find-class ',class) ',name)))
-       (fset sym func)
-       (put sym 'luna-method-qualifier ,method-qualifier)
-       )))
+    (` (let ((func (function
+		    (lambda (, (if self
+				   (cons self (cdr args))
+				 (cdr args)))
+		      (,@ definition))))
+	     (sym (luna-class-find-or-make-member
+		   (luna-find-class '(, class)) '(, name))))
+	 (fset sym func)
+	 (put sym 'luna-method-qualifier (, method-qualifier))
+	 ))
+    ))
 
 (put 'luna-define-method 'lisp-indent-function 'defun)
 
 (def-edebug-spec luna-define-method
-  (&define name [&optional &or ":before" ":after"]
+  (&define name [&optional &or ":before" ":after" ":around"]
 	   ((arg symbolp)
 	    [&rest arg]
 	    [&optional ["&optional" arg &rest arg]]
@@ -182,6 +203,9 @@ BODY is the body of method."
 	       (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))
 	       ))
@@ -189,31 +213,60 @@ BODY is the body of method."
       )))
 
 (defmacro luna-find-functions (entity service)
-  `(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))
+  (` (luna-class-find-functions (luna-find-class (luna-class-name (, entity)))
+				(, service))))
+
+(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."
-  `(aref ,entity 0))
+  (` (aref (, entity) 0)))
 
 (defmacro luna-set-class-name (entity name)
-  `(aset ,entity 0 ,name))
+  (` (aset (, entity) 0 (, name))))
 
 (defmacro luna-get-obarray (entity)
-  `(aref ,entity 1))
+  (` (aref (, entity) 1)))
 
 (defmacro luna-set-obarray (entity obarray)
-  `(aset ,entity 1 ,obarray))
+  (` (aset (, entity) 1 (, obarray))))
 
 (defun luna-make-entity (type &rest init-args)
   "Make instance of luna-class TYPE and return it.
@@ -223,7 +276,7 @@ It must be plist and each slot name must have prefix `:'."
 	 (v (make-vector (luna-class-number-of-slots c) nil)))
     (luna-set-class-name v type)
     (luna-set-obarray v (make-vector 7 0))
-    (apply #'luna-send v 'initialize-instance v init-args)
+    (apply (function luna-send) v 'initialize-instance v init-args)
     ))
 
 (defsubst luna-arglist-to-arguments (arglist)
@@ -240,15 +293,15 @@ It must be plist and each slot name must have prefix `:'."
   "Define generic-function NAME.
 ARGS is argument of and DOC is DOC-string."
   (if doc
-      `(defun ,(intern (symbol-name name)) ,args
-	 ,doc
-	 (luna-send ,(car args) ',name
-		    ,@(luna-arglist-to-arguments args))
-	 )
-    `(defun ,(intern (symbol-name name)) ,args
-       (luna-send ,(car args) ',name
-		  ,@(luna-arglist-to-arguments args))
-       )))
+      (` (defun (, (intern (symbol-name name))) (, args)
+	   (, doc)
+	   (luna-send (, (car args)) '(, name)
+		      (,@ (luna-arglist-to-arguments args)))
+	   ))
+    (` (defun (, (intern (symbol-name name))) (, args)
+	 (luna-send (, (car args)) '(, name)
+		    (,@ (luna-arglist-to-arguments args)))
+	 ))))
 
 (put 'luna-define-generic 'lisp-indent-function 'defun)
 
@@ -257,34 +310,35 @@ ARGS is argument of and DOC is DOC-string."
   (let ((entity-class (luna-find-class class-name))
 	parents parent-class)
     (mapatoms
-     (lambda (slot)
-       (if (luna-class-slot-index entity-class slot)
-	   (catch 'derived
-	     (setq parents (luna-class-parents entity-class))
-	     (while parents
-	       (setq parent-class (luna-find-class (car parents)))
-	       (if (luna-class-slot-index parent-class slot)
-		   (throw 'derived nil))
-	       (setq parents (cdr parents))
-	       )
-	     (eval
-	      `(progn
-		 (defmacro ,(intern (format "%s-%s-internal"
-					    class-name slot))
-		   (entity)
-		   (list 'aref entity
-			 ,(luna-class-slot-index entity-class
-						 (intern (symbol-name slot)))
-			 ))
-		 (defmacro ,(intern (format "%s-set-%s-internal"
-					    class-name slot))
-		   (entity value)
-		   (list 'aset entity
-			 ,(luna-class-slot-index
-			   entity-class (intern (symbol-name slot)))
-			 value))
-		 ))
-	     )))
+     (function
+      (lambda (slot)
+	(if (luna-class-slot-index entity-class slot)
+	    (catch 'derived
+	      (setq parents (luna-class-parents entity-class))
+	      (while parents
+		(setq parent-class (luna-find-class (car parents)))
+		(if (luna-class-slot-index parent-class slot)
+		    (throw 'derived nil))
+		(setq parents (cdr parents))
+		)
+	      (eval
+	       (` (progn
+		    (defmacro (, (intern (format "%s-%s-internal"
+						 class-name slot)))
+		      (entity)
+		      (list 'aref entity
+			    (, (luna-class-slot-index entity-class
+						      (intern (symbol-name slot))))
+			    ))
+		    (defmacro (, (intern (format "%s-set-%s-internal"
+						 class-name slot)))
+		      (entity value)
+		      (list 'aset entity
+			    (, (luna-class-slot-index
+				entity-class (intern (symbol-name slot))))
+			    value))
+		    )))
+	      ))))
      (luna-class-obarray entity-class))))
 
 (luna-define-class-function 'standard-object)