From 9d43a05430beb5f6f1ad70b6bcb4c6d2f698a154 Mon Sep 17 00:00:00 2001 From: tomo Date: Thu, 14 Dec 2000 04:57:26 +0000 Subject: [PATCH] Apply Handa-san's patch <200012130452.NAA13293@etlken.etl.go.jp>. --- mime/luna.el | 122 ++++++++++++++++++++++++++++++++++++++++++------------- mime/mmbabyl.el | 23 +++++++++-- 2 files changed, 114 insertions(+), 31 deletions(-) diff --git a/mime/luna.el b/mime/luna.el index 7a8cb53..d9a4fa3 100644 --- a/mime/luna.el +++ b/mime/luna.el @@ -31,30 +31,42 @@ ;;; (defmacro luna-find-class (name) - "Return the luna-class of the given NAME." + "Return a luna-class that has NAME." `(get ,name 'luna-class)) +;; Give NAME (symbol) the luna-class CLASS. (defmacro luna-set-class (name class) `(put ,name 'luna-class ,class)) +;; Return the obarray of luna-class CLASS. (defmacro luna-class-obarray (class) `(aref ,class 1)) +;; Return the parents of luna-class CLASS. (defmacro luna-class-parents (class) `(aref ,class 2)) +;; Return the number of slots of luna-class CLASS. (defmacro luna-class-number-of-slots (class) `(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)) +(defmacro luna-define-class (class &optional parents slots) + "Define CLASS as a luna-class. +CLASS always inherits the luna-class `standard-object'. + +The optional 1st arg PARENTS is a list luna-class names. These +luna-classes are also inheritted by CLASS. + +The optional 2nd arg SLOTS is a list of slots CLASS will have." + `(luna-define-class-function ',class ',(append parents '(standard-object)) ',slots)) -(defun luna-define-class-function (type &optional parents slots) + +;; Define CLASS as a luna-class. PARENTS, if non-nil, is a list of +;; luna-class names inherited by CLASS. SLOTS, if non-nil, is a list +;; of slots belonging to CLASS. + +(defun luna-define-class-function (class &optional parents slots) (let ((oa (make-vector 31 0)) (rest parents) parent name @@ -76,7 +88,11 @@ If SLOTS is specified, TYPE will be defined to have them." (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)))) + (luna-set-class class (vector 'class oa parents i)))) + + +;; Return a member of CLASS that has name MEMBER-NAME. +;;;%%% member って何？ slots? subclass? (defun luna-class-find-member (class member-name) (or (stringp member-name) @@ -91,33 +107,53 @@ If SLOTS is specified, TYPE will be defined to have them." member-name))))) ret))) + +;; Return a member of CLASS that has name MEMBER-NAME. If CLASS +;; doesnt' have such a member, make it for CLASS. + (defsubst luna-class-find-or-make-member (class member-name) (or (stringp member-name) (setq member-name (symbol-name member-name))) (intern member-name (luna-class-obarray class))) + +;; Return the index number of SLOT-NAME in CLASS. + (defmacro luna-class-slot-index (class slot-name) `(get (luna-class-find-member ,class ,slot-name) 'luna-slot-index)) + +;;;%%% docstring を大幅に書き直したので正しいかチェックして！ +;;;%%% 特に VAR の意味が分らない。 + (defmacro luna-define-method (name &rest definition) - "Define NAME as a method function of a class. + "Define NAME as a method of a luna class. Usage of this macro follows: - (luna-define-method NAME [METHOD-QUALIFIER] ARGLIST [DOCSTRING] BODY...) + (luna-define-method NAME [METHOD-QUALIFIER] ARGLIST [DOCSTRING] BODY...) + +The optional 1st argument METHOD-QUALIFIER specifies when and how the +method is called. -NAME is the name of method. +If it is :before, call the method before calling the parents' methods. -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. +If it is :after, call the method after calling the parents' methods. -Optional argument DOCSTRING is the documentation of method. +If it is :around, call the method only. The parents' methods can be +executed by calling the function `luna-call-next-method' in BODY. -BODY is the body of method." +Otherwize, call the method only, and the parents' methods are never +executed. In this case, METHOD-QUALIFIER is treated as ARGLIST. + +ARGLIST has the form ((VAR CLASS) METHOD-ARG-LIST), where VAR is a +variable name, CLASS is a class name, METHOD-ARG-LIST is an argument +list of the method, and its format is like an argument list of lambda. + +The optional 4th argument DOCSTRING is the documentation of the +method. If it is not string, it is treated as BODY. + +The optional 5th BODY is the body of the method." (let ((method-qualifier (pop definition)) args specializer class self) (if (memq method-qualifier '(:before :after :around)) @@ -149,6 +185,10 @@ BODY is the body of method." &optional ["&rest" arg]) def-body)) + +;; Return a list of method functions named SERVICE registered in the +;; parents of CLASS. + (defun luna-class-find-parents-functions (class service) (let ((parents (luna-class-parents class)) ret) @@ -159,6 +199,9 @@ BODY is the body of method." service))))) ret)) +;; Return a list of method functions named SERVICE registered in CLASS +;; and the parents.. + (defun luna-class-find-functions (class service) (let ((sym (luna-class-find-member class service))) (if (fboundp sym) @@ -207,8 +250,12 @@ BODY is the body of method." `(luna-class-find-functions (luna-find-class (luna-class-name ,entity)) ,service)) +;;;%%% ENTITY と MESSAGE の説明は合ってる？ + (defsubst luna-send (entity message &rest luna-current-method-arguments) "Send MESSAGE to ENTITY, and return the result. +ENTITY is an instance of a luna class, and MESSAGE is a method name of +the luna class. LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE." (let ((luna-next-methods (luna-find-functions entity message)) luna-current-method @@ -230,7 +277,9 @@ LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE." (defvar luna-current-method-arguments nil)) (defun luna-call-next-method () - "Call the next method in a method with :around qualifier." + "Call the next method in the current method function. +A method function that has :around qualifier should call this function +to execute the parents' methods." (let (luna-current-method luna-previous-return-value) (while (and luna-next-methods @@ -245,13 +294,14 @@ LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE." t)))) luna-previous-return-value)) -(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)) +(defun luna-make-entity (class &rest init-args) + "Make an entity (instance) of luna-class CLASS and return it. +INIT-ARGS is a plist of the form (:SLOT1 VAL1 :SLOT2 VAL2 ...), +where SLOTs are slots of CLASS and the VALs are initial values of +the corresponding SLOTs." + (let* ((c (get class 'luna-class)) (v (make-vector (luna-class-number-of-slots c) nil))) - (luna-set-class-name v type) + (luna-set-class-name v class) (luna-set-obarray v (make-vector 7 0)) (apply #'luna-send v 'initialize-instance v init-args))) @@ -259,6 +309,8 @@ It must be plist and each slot name must have prefix `:'." ;;; @ 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)) @@ -272,6 +324,10 @@ It must be plist and each slot name must have prefix `:'." luna-next-methods)) (luna-call-next-method))) + +;; Convert ARGLIST (argument list spec for a method function) to the +;; actual list of arguments. + (defsubst luna-arglist-to-arguments (arglist) (let (dest) (while arglist @@ -281,9 +337,14 @@ It must be plist and each slot name must have prefix `:'." (setq arglist (cdr arglist))) (nreverse dest))) + +;;;%%% generic-function って何？それで define するって具体的にどういう +;;;%%% こと？ + (defmacro luna-define-generic (name args &optional doc) "Define generic-function NAME. -ARGS is argument of and DOC is DOC-string." +ARGS is the argument list for NAME. +The optional 3rd arg DOC is the documentation string for NAME." (if doc `(progn (defun ,(intern (symbol-name name)) ,args @@ -303,6 +364,8 @@ ARGS is argument of and DOC is DOC-string." ;;; @ accessor ;;; +;;;%%% internal accessor って何？どう使うの？ + (defun luna-define-internal-accessors (class-name) "Define internal accessors for an entity of CLASS-NAME." (let ((entity-class (luna-find-class class-name)) @@ -338,10 +401,13 @@ ARGS is argument of and DOC is DOC-string." ;;; @ standard object ;;; +;; Define super class of all luna classes. (luna-define-class-function 'standard-object) +;;;%%% DOCSTRING 正しい？ (luna-define-method initialize-instance ((entity standard-object) &rest init-args) + "Initialize slots of ENTITY whose luna class is `standard-object'." (let* ((c (luna-find-class (luna-class-name entity))) (oa (luna-class-obarray c)) s i) diff --git a/mime/mmbabyl.el b/mime/mmbabyl.el index 978a6f9..559a9e5 100644 --- a/mime/mmbabyl.el +++ b/mime/mmbabyl.el @@ -5,7 +5,7 @@ ;; Author: MORIOKA Tomohiko ;; Keywords: Babyl, RMAIL, MIME, multimedia, mail -;; This file is part of FLIM (Faithful Library about Internet Message). +;; This file is part of GNU Emacs. ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -31,11 +31,12 @@ (visible-header-start visible-header-end)) - (luna-define-internal-accessors 'mime-babyl-entity) - ) + (luna-define-internal-accessors 'mime-babyl-entity)) (luna-define-method initialize-instance :after ((entity mime-babyl-entity) &rest init-args) + "Initialize slots of ENTITY. +ENTITY is an instance of `mime-babyl-entity'." (or (mime-buffer-entity-buffer-internal entity) (mime-buffer-entity-set-buffer-internal entity (get-buffer (mime-entity-location-internal entity)))) @@ -95,6 +96,10 @@ ;;; (luna-define-method mime-insert-entity ((entity mime-babyl-entity)) + "Insert ENTITY into the current buffer. +ENTITY is an instance of `mime-babyl-entity'. +The header part and the body part of ENTITY are separated by a blank +line." (insert-buffer-substring (mime-buffer-entity-buffer-internal entity) (mime-buffer-entity-header-start-internal entity) (mime-buffer-entity-header-end-internal entity)) @@ -106,6 +111,8 @@ (luna-define-method mime-write-entity ((entity mime-babyl-entity) filename) + "Write ENTITY into FILENAME. +ENTITY is an instance of `mime-babyl-entity'." (with-temp-buffer (mime-insert-entity entity) (write-region-as-raw-text-CRLF (point-min) (point-max) filename))) @@ -126,9 +133,15 @@ ;;; @ header field ;;; +;;;%%% docstring を完成させて。 + (luna-define-method mime-insert-header ((entity mime-babyl-entity) &optional invisible-fields visible-fields) + "Insert the header of ENTITY in the current buffer. +ENTITY is an instance of `mime-babyl-entity'. +The optional 1st arguemnt INVISIBLE-FIELDS is a list of .... +The optional 2nd arguemnt VISIBLE-FIELDS is a list of ...." (mime-insert-header-from-buffer (mime-buffer-entity-buffer-internal entity) (mime-babyl-entity-visible-header-start-internal entity) @@ -140,7 +153,11 @@ ;;; @ children ;;; +;;;%%% docstring 合ってる？ + (luna-define-method mime-entity-children ((entity mime-babyl-entity)) + "Return a list of ENTITY's children. +ENTITY is an instance of `mime-babyl-entity'." (let* ((content-type (mime-entity-content-type entity)) (primary-type (mime-content-type-primary-type content-type)) sub-type) -- 1.7.10.4