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

diff --git a/luna.el b/luna.el
index bc23bc5..f3504a6 100644
--- a/luna.el
+++ b/luna.el
@@ -1,6 +1,7 @@
 ;;; luna.el --- tiny OOP system kernel
 
 ;; Copyright (C) 1999 Electrotechnical Laboratory, JAPAN.
+;; Licensed to the Free Software Foundation.
 
 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
 ;; Keywords: OOP
@@ -26,27 +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))))
+
+(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
@@ -55,62 +77,27 @@ 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-member-index))
-		    (setq name (symbol-name sym))
-		    (unless (intern-soft name oa)
-		      (put (intern name oa) 'luna-member-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)
     (while rest
       (setq name (symbol-name (pop rest)))
       (unless (intern-soft name oa)
-	(put (intern name oa) 'luna-member-index i)
+	(put (intern name oa) 'luna-slot-index i)
 	(setq i (1+ i))
 	))
-    `(luna-set-class ',type
-		     (vector 'class ,oa ',parents ,i))
+    (luna-set-class type (vector 'class oa parents i))
     ))
 
-(defmacro luna-class-name (entity)
-  "Return class-name of the ENTITY."
-  `(aref ,entity 0))
-
-(defmacro luna-set-class-name (entity name)
-  `(aset ,entity 0 ,name))
-
-(defmacro luna-get-obarray (entity)
-  `(aref ,entity 1))
-
-(defmacro luna-set-obarray (entity obarray)
-  `(aset ,entity 1 ,obarray))
-
-(defmacro luna-make-entity (type &rest init-args)
-  "Make instance of luna-class TYPE and return it.
-If INIT-ARGS is specified, it is used as initial values of the slots.
-It must be plist and each slot name must have prefix `:'."
-  `(apply #'luna-make-entity-function ',type ',init-args))
-
-(defsubst luna-make-entity-function (type &rest init-args)
-  (let* ((c (get type 'luna-class))
-	 (v (make-vector (luna-class-number-of-slots c) nil))
-	 (oa (luna-class-obarray c))
-	 s i)
-    (luna-set-class-name v type)
-    (luna-set-obarray v (make-vector 7 0))
-    (while init-args
-      (setq s (intern-soft (substring (symbol-name (pop init-args)) 1) oa)
-	    i (pop init-args))
-      (if s
-	  (aset v (get s 'luna-member-index) i)
-	))
-    (luna-send v 'initialize-instance v)
-    v))
-
-(defsubst luna-class-find-member (class member-name)
+(defun luna-class-find-member (class member-name)
   (or (stringp member-name)
       (setq member-name (symbol-name member-name)))
   (or (intern-soft member-name (luna-class-obarray class))
@@ -129,11 +116,11 @@ It must be plist and each slot name must have prefix `:'."
   (intern member-name (luna-class-obarray class)))
 
 (defmacro luna-class-slot-index (class slot-name)
-  `(get (luna-class-find-member ,class ,slot-name) 'luna-member-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."
@@ -143,45 +130,154 @@ It must be plist and each slot name must have prefix `:'."
   "Store VALUE into SLOT of ENTITY."
   (aset entity (luna-slot-index entity slot) value))
 
-(defmacro luna-define-method (name args &rest body)
-  "Define NAME as a method function of (nth 1 (car ARGS)) backend.
-
-ARGS is like an argument list of lambda, but (car ARGS) must be
-specialized parameter.  (car (car ARGS)) is name of variable and (nth
-1 (car ARGS)) is name of backend."
-  (let* ((specializer (car args))
-	 (class (nth 1 specializer))
-	 (self (car specializer)))
-    `(let ((func (lambda ,(if self
-			      (cons self (cdr args))
-			    (cdr args))
-		   ,@body)))
-       (fset (luna-class-find-or-make-member (luna-find-class ',class) ',name)
-	     func))))
+(defmacro luna-define-method (name &rest definition)
+  "Define NAME as a method function of a class.
+
+Usage of this macro follows:
+
+  (luna-define-method NAME [METHOD-QUALIFIER] ARGLIST [DOCSTRING] BODY...) 
+
+NAME is the name of method.
+
+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 :around))
+	(setq args (pop definition))
+      (setq args method-qualifier
+	    method-qualifier nil)
+      )
+    (setq specializer (car args)
+	  class (nth 1 specializer)
+	  self (car specializer))
+    (` (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)
 
-(defsubst luna-class-find-function (class service)
+(def-edebug-spec luna-define-method
+  (&define name [&optional &or ":before" ":after" ":around"]
+	   ((arg symbolp)
+	    [&rest arg]
+	    [&optional ["&optional" arg &rest arg]]
+	    &optional ["&rest" arg]
+	    )
+	   def-body))
+
+(defun luna-class-find-parents-functions (class service)
+  (let ((parents (luna-class-parents class))
+	ret)
+    (while (and parents
+		(null
+		 (setq ret (luna-class-find-functions
+			    (luna-find-class (pop parents))
+			    service)))))
+    ret))
+
+(defun luna-class-find-functions (class service)
   (let ((sym (luna-class-find-member class service)))
     (if (fboundp sym)
-	(symbol-function sym)
-      (let ((parents (luna-class-parents class))
-	    ret)
-	(while (and parents
-		    (null
-		     (setq ret (luna-class-find-function
-				(luna-find-class (pop parents))
-				service)))))
-	ret))))
+	(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)
+      )))
+
+(defmacro luna-find-functions (entity service)
+  (` (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-find-function (entity service)
-  `(luna-class-find-function (luna-find-class (luna-class-name ,entity))
-			     ,service))
+(defmacro luna-class-name (entity)
+  "Return class-name of the ENTITY."
+  (` (aref (, entity) 0)))
+
+(defmacro luna-set-class-name (entity name)
+  (` (aset (, entity) 0 (, name))))
 
-(defsubst luna-send (entity message &rest args)
-  "Send MESSAGE to ENTITY with ARGS, and return the result."
-  (apply (luna-find-function entity message)
-	 entity args))
+(defmacro luna-get-obarray (entity)
+  (` (aref (, entity) 1)))
+
+(defmacro luna-set-obarray (entity obarray)
+  (` (aset (, entity) 1 (, obarray))))
+
+(defun luna-make-entity (type &rest init-args)
+  "Make instance of luna-class TYPE and return it.
+If INIT-ARGS is specified, it is used as initial values of the slots.
+It must be plist and each slot name must have prefix `:'."
+  (let* ((c (get type 'luna-class))
+	 (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 (function luna-send) v 'initialize-instance v init-args)
+    ))
 
 (defsubst luna-arglist-to-arguments (arglist)
   (let (dest)
@@ -197,18 +293,69 @@ specialized parameter.  (car (car ARGS)) is name of variable and (nth
   "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 (cdr args)))
-	 )
-    `(defun ,(intern (symbol-name name)) ,args
-       (luna-send ,(car args) ',name
-		  ,@(luna-arglist-to-arguments (cdr 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)
 
+(defun luna-define-internal-accessors (class-name)
+  "Define internal accessors for an entity of CLASS-NAME."
+  (let ((entity-class (luna-find-class class-name))
+	parents parent-class)
+    (mapatoms
+     (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)
+
+(luna-define-method initialize-instance ((entity standard-object)
+					 &rest init-args)
+  (let* ((c (luna-find-class (luna-class-name entity)))
+	 (oa (luna-class-obarray c))
+	 s i)
+    (while init-args
+      (setq s (intern-soft (substring (symbol-name (pop init-args)) 1) oa)
+	    i (pop init-args))
+      (if s
+	  (aset entity (get s 'luna-slot-index) i)
+	))
+    entity))
+
 
 ;;; @ end
 ;;;