From: ueno Date: Sun, 12 Nov 2000 20:22:08 +0000 (+0000) Subject: * luna.el (luna-define-method): Clear method cache. X-Git-Tag: deisui-1_14_0-2000-12-14~17 X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=c1fc1f2994d069a6ab8cf8032be7f3882844c952;p=elisp%2Fflim.git * luna.el (luna-define-method): Clear method cache. (luna-apply-generic): New function. (luna-define-generic): Use `luna-apply-generic' instead of `luna-send'. --- diff --git a/ChangeLog b/ChangeLog index 2f7ebb1..0456174 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,11 @@ 2000-11-12 Daiki Ueno + * luna.el (luna-define-method): Clear method cache. + (luna-apply-generic): New function. + (luna-define-generic): Use `luna-apply-generic' instead of `luna-send'. + +2000-11-12 Daiki Ueno + * smtp.el (smtp-primitive-data): Use `beginning-of-line' instead of `forward-char'. (smtp-read-response): Don't bind `case-fold-search'. diff --git a/luna.el b/luna.el index 48da490..7f6f1c4 100644 --- a/luna.el +++ b/luna.el @@ -84,19 +84,15 @@ If SLOTS is specified, TYPE will be defined to have them." (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 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-slot-index i) - (setq i (1+ i)) - )) - (luna-set-class type (vector 'class oa parents i)) - )) + (setq i (1+ i)))) + (luna-set-class type (vector 'class oa parents i)))) (defun luna-class-find-member (class member-name) (or (stringp member-name) @@ -143,8 +139,7 @@ BODY is the body of method." (if (memq method-qualifier '(:before :after :around)) (setq args (pop definition)) (setq args method-qualifier - method-qualifier nil) - ) + method-qualifier nil)) (setq specializer (car args) class (nth 1 specializer) self (car specializer)) @@ -153,10 +148,12 @@ BODY is the body of method." (cdr args)) ,@definition)) (sym (luna-class-find-or-make-member - (luna-find-class ',class) ',name))) + (luna-find-class ',class) ',name)) + (cache (get ',name 'luna-method-cache))) + (if cache + (unintern ',class cache)) (fset sym func) - (put sym 'luna-method-qualifier ,method-qualifier) - ))) + (put sym 'luna-method-qualifier ,method-qualifier)))) (put 'luna-define-method 'lisp-indent-function 'defun) @@ -165,8 +162,7 @@ BODY is the body of method." ((arg symbolp) [&rest arg] [&optional ["&optional" arg &rest arg]] - &optional ["&rest" arg] - ) + &optional ["&rest" arg]) def-body)) (defun luna-class-find-parents-functions (class service) @@ -184,20 +180,15 @@ BODY is the body of method." (if (fboundp sym) (cond ((eq (get sym 'luna-method-qualifier) :before) (cons (symbol-function sym) - (luna-class-find-parents-functions class service)) - ) + (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))) - ) + (list (symbol-function sym)))) ((eq (get sym 'luna-method-qualifier) :around) - (cons sym (luna-class-find-parents-functions class service)) - ) + (cons sym (luna-class-find-parents-functions class service))) (t - (list (symbol-function sym)) - )) - (luna-class-find-parents-functions class service) - ))) + (list (symbol-function sym)))) + (luna-class-find-parents-functions class service)))) ;;; @ instance (entity) @@ -252,8 +243,7 @@ LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE." (eval-when-compile (defvar luna-next-methods nil) - (defvar luna-current-method-arguments nil) - ) + (defvar luna-current-method-arguments nil)) (defun luna-call-next-method () "Call the next method in a method with :around qualifier." @@ -279,20 +269,31 @@ 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 #'luna-send v 'initialize-instance v init-args))) ;;; @ interface (generic function) ;;; +(defun luna-apply-generic (entity message &rest luna-current-method-arguments) + (let* ((class (luna-class-name entity)) + (cache (get message 'luna-method-cache)) + (sym (intern-soft (symbol-name class) cache)) + luna-next-methods) + (if sym + (setq luna-next-methods (symbol-value sym)) + (setq luna-next-methods + (luna-find-functions entity message)) + (set (intern (symbol-name class) cache) + luna-next-methods)) + (luna-call-next-method))) + (defsubst luna-arglist-to-arguments (arglist) (let (dest) (while arglist (let ((arg (car arglist))) (or (memq arg '(&optional &rest)) - (setq dest (cons arg dest))) - ) + (setq dest (cons arg dest)))) (setq arglist (cdr arglist))) (nreverse dest))) @@ -300,15 +301,17 @@ 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)) - ))) + `(progn + (defun ,(intern (symbol-name name)) ,args + ,doc + (luna-apply-generic ,(car args) ',name + ,@(luna-arglist-to-arguments args))) + (put ',name 'luna-method-cache (make-vector 31 0))) + `(progn + (defun ,(intern (symbol-name name)) ,args + (luna-apply-generic ,(car args) ',name + ,@(luna-arglist-to-arguments args))) + (put ',name 'luna-method-cache (make-vector 31 0))))) (put 'luna-define-generic 'lisp-indent-function 'defun) @@ -329,8 +332,7 @@ ARGS is argument of and DOC is DOC-string." (setq parent-class (luna-find-class (car parents))) (if (luna-class-slot-index parent-class slot) (throw 'derived nil)) - (setq parents (cdr parents)) - ) + (setq parents (cdr parents))) (eval `(progn (defmacro ,(intern (format "%s-%s-internal" @@ -338,17 +340,14 @@ ARGS is argument of and DOC is DOC-string." (entity) (list 'aref entity ,(luna-class-slot-index entity-class - (intern (symbol-name slot))) - )) + (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)) - )) - ))) + value))))))) (luna-class-obarray entity-class)))) @@ -366,8 +365,7 @@ ARGS is argument of and DOC is DOC-string." (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) - )) + (aset entity (get s 'luna-slot-index) i))) entity))