From 31fb52db733e75a0b984187df27f7fda615bd132 Mon Sep 17 00:00:00 2001 From: tomo Date: Tue, 5 Dec 2000 16:25:46 +0000 Subject: [PATCH] sync with deisui-1_14. --- luna.el | 112 +++++++++++++++++++++++++++------------------------------------ 1 file changed, 47 insertions(+), 65 deletions(-) diff --git a/luna.el b/luna.el index 48da490..7a8cb53 100644 --- a/luna.el +++ b/luna.el @@ -26,15 +26,6 @@ (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))) - ;;; @ class ;;; @@ -64,13 +55,6 @@ 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 @@ -84,19 +68,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 +123,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 +132,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 +146,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 +164,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 +227,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 +253,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 +285,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 +316,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 +324,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 +349,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)) -- 1.7.10.4