X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=luna.el;h=f3504a6bc15b33746f96f45733dde7f355c07658;hb=0f0317cf179760a10043565f80f31853a6161bff;hp=a35432becf4617f125189e2cd5d9d61530f18747;hpb=83eb3409c1be37c17c52821e29e41e7f953d0fb4;p=elisp%2Fflim.git diff --git a/luna.el b/luna.el index a35432b..f3504a6 100644 --- a/luna.el +++ b/luna.el @@ -29,41 +29,46 @@ (eval-when-compile (require 'static)) -(static-unless (or (>= emacs-major-version 20)(featurep 'xemacs)) - (defconst :before ':before) - (defconst :after ':after) - (defconst :around ':around)) +(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-unless (or (>= emacs-major-version 20)(featurep 'xemacs)) - (let (key) - (dolist (slot slots) - (setq key (intern (format ":%s" slot))) - (set key key)))) + (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 @@ -72,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) @@ -110,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." @@ -153,15 +159,17 @@ 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) @@ -205,8 +213,8 @@ BODY is the body of method." ))) (defmacro luna-find-functions (entity service) - `(luna-class-find-functions (luna-find-class (luna-class-name ,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. @@ -249,16 +257,16 @@ LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE." (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. @@ -268,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) @@ -285,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) @@ -302,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)