X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=luna.el;h=e66d26575e0f9f81864f25ec017c9f9a8fc785de;hb=5877831bf375491115b835d97a700a83227f9ef8;hp=8414562802f5ed820ae64a8cfe322d245d7d05a1;hpb=7c4e3d64dd9bbd82c7a5c4885eb581831bef1f5d;p=elisp%2Fflim.git diff --git a/luna.el b/luna.el index 8414562..e66d265 100644 --- 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)) @@ -48,9 +57,17 @@ 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 ',parents ',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 @@ -111,45 +128,128 @@ If SLOTS is specified, TYPE will be defined to have them." "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. +(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. -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))) +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 (lambda ,(if self (cons self (cdr args)) (cdr args)) - ,@body))) - (fset (luna-class-find-or-make-member (luna-find-class ',class) ',name) - func)))) + ,@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) -(defun 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)))) - -(defmacro luna-find-function (entity service) - `(luna-class-find-function (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." - (apply (luna-find-function entity message) - args)) + (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-class-name (entity) "Return class-name of the ENTITY." @@ -169,19 +269,11 @@ specialized parameter. (car (car ARGS)) is name of variable and (nth 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)) - (oa (luna-class-obarray c)) - s i) + (v (make-vector (luna-class-number-of-slots c) nil))) (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-slot-index) i) - )) - (luna-send v 'initialize-instance v) - v)) + (apply #'luna-send v 'initialize-instance v init-args) + )) (defsubst luna-arglist-to-arguments (arglist) (let (dest) @@ -243,7 +335,22 @@ ARGS is argument of and DOC is DOC-string." )) ))) (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 ;;;