-;;; alist.el --- utility functions about association-list
+;;; alist.el --- utility functions for association list
;; Copyright (C) 1993,1994,1995,1996,1998,2000 Free Software Foundation, Inc.
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
;; Keywords: alist
-;; This file is part of APEL (A Portable Emacs Library).
+;; 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
;;; Code:
;;;###autoload
-(defun put-alist (item value alist)
- "Modify ALIST to set VALUE to ITEM.
-If there is a pair whose car is ITEM, replace its cdr by VALUE.
-If there is not such pair, create new pair (ITEM . VALUE) and
-return new alist whose car is the new pair and cdr is ALIST.
-\[tomo's ELIS like function]"
- (let ((pair (assoc item alist)))
- (if pair
+(defun put-alist (key value alist)
+ "Set cdr of an element (KEY . ...) in ALIST to VALUE and return ALIST.
+If there is no such element, create a new pair (KEY . VALUE) and
+return a new alist whose car is the new pair and cdr is ALIST."
+ (let ((elm (assoc key alist)))
+ (if elm
(progn
- (setcdr pair value)
+ (setcdr elm value)
alist)
- (cons (cons item value) alist)
- )))
+ (cons (cons key value) alist))))
;;;###autoload
-(defun del-alist (item alist)
- "If there is a pair whose key is ITEM, delete it from ALIST.
-\[tomo's ELIS emulating function]"
- (if (equal item (car (car alist)))
+(defun del-alist (key alist)
+ "Delete an element whose car equals KEY from ALIST.
+Return the modified ALIST."
+ (if (equal key (car (car alist)))
(cdr alist)
(let ((pr alist)
- (r (cdr alist))
- )
+ (r (cdr alist)))
(catch 'tag
(while (not (null r))
- (if (equal item (car (car r)))
+ (if (equal key (car (car r)))
(progn
(rplacd pr (cdr r))
(throw 'tag alist)))
(setq pr r)
- (setq r (cdr r))
- )
+ (setq r (cdr r)))
alist))))
;;;###autoload
-(defun set-alist (symbol item value)
- "Modify a alist indicated by SYMBOL to set VALUE to ITEM."
+(defun set-alist (symbol key value)
+ "Set cdr of an element (KEY . ...) in the alist bound to SYMBOL to VALUE."
(or (boundp symbol)
- (set symbol nil)
- )
- (set symbol (put-alist item value (symbol-value symbol)))
- )
+ (set symbol nil))
+ (set symbol (put-alist key value (symbol-value symbol))))
;;;###autoload
-(defun remove-alist (symbol item)
- "Remove ITEM from the alist indicated by SYMBOL."
+(defun remove-alist (symbol key)
+ "Delete an element whose car equals KEY from the alist bound to SYMBOL."
(and (boundp symbol)
- (set symbol (del-alist item (symbol-value symbol)))
- ))
+ (set symbol (del-alist key (symbol-value symbol)))))
;;;###autoload
(defun modify-alist (modifier default)
- "Modify alist DEFAULT into alist MODIFIER."
+ "Store elements in the alist MODIFIER in the alist DEFAULT.
+Return the modified alist."
(mapcar (function
(lambda (as)
- (setq default (put-alist (car as)(cdr as) default))
- ))
+ (setq default (put-alist (car as)(cdr as) default))))
modifier)
default)
;;;###autoload
-(defun set-modified-alist (sym modifier)
- "Modify a value of a symbol SYM into alist MODIFIER.
-The symbol SYM should be alist. If it is not bound,
-its value regard as nil."
- (if (not (boundp sym))
- (set sym nil)
- )
- (set sym (modify-alist modifier (eval sym)))
- )
+(defun set-modified-alist (symbol modifier)
+ "Store elements in the alist MODIFIER in an alist bound to SYMBOL.
+If SYMBOL is not bound, set it to nil at first."
+ (if (not (boundp symbol))
+ (set symbol nil))
+ (set symbol (modify-alist modifier (eval symbol))))
;;; @ association-vector-list
;;;###autoload
(defun vassoc (key avlist)
- "Search AVLIST for a vector whose first element is equal to KEY.
+ "Search AVLIST for an element whose first element equals KEY.
+AVLIST is a list of vectors.
See also `assoc'."
- (let (v)
- (while (and (setq v (car avlist))
- (not (equal key (aref v 0))))
- (setq avlist (cdr avlist)))
- v))
+ (while (and avlist
+ (not (equal key (aref (car avlist) 0))))
+ (setq avlist (cdr avlist)))
+ (and avlist
+ (car avlist)))
;;; @ end
;;;
(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
(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 \e$B$C$F2?!)\e(B slots? subclass?
(defun luna-class-find-member (class member-name)
(or (stringp member-name)
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 \e$B$rBgI}$K=q$-D>$7$?$N$G@5$7$$$+%A%'%C%/$7$F!*\e(B
+;;;%%% \e$BFC$K\e(B VAR \e$B$N0UL#$,J,$i$J$$!#\e(B
+
(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))
&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)
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)
`(luna-class-find-functions (luna-find-class (luna-class-name ,entity))
,service))
+;;;%%% ENTITY \e$B$H\e(B MESSAGE \e$B$N@bL@$O9g$C$F$k!)\e(B
+
(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
(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
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)))
;;; @ interface (generic function)
;;;
+;;;%%% \e$B$I$&%3%a%s%H$r=q$$$?$i$h$$$+J,$i$J$$!#\e(B
+
(defun luna-apply-generic (entity message &rest luna-current-method-arguments)
(let* ((class (luna-class-name entity))
(cache (get message 'luna-method-cache))
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
(setq arglist (cdr arglist)))
(nreverse dest)))
+
+;;;%%% generic-function \e$B$C$F2?!)$=$l$G\e(B define \e$B$9$k$C$F6qBNE*$K$I$&$$$&\e(B
+;;;%%% \e$B$3$H!)\e(B
+
(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
;;; @ accessor
;;;
+;;;%%% internal accessor \e$B$C$F2?!)$I$&;H$&$N!)\e(B
+
(defun luna-define-internal-accessors (class-name)
"Define internal accessors for an entity of CLASS-NAME."
(let ((entity-class (luna-find-class class-name))
;;; @ standard object
;;;
+;; Define super class of all luna classes.
(luna-define-class-function 'standard-object)
+;;;%%% DOCSTRING \e$B@5$7$$!)\e(B
(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)
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
;; 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
(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))))
;;;
(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))
(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)))
;;; @ header field
;;;
+;;;%%% docstring \e$B$r40@.$5$;$F!#\e(B
+
(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)
;;; @ children
;;;
+;;;%%% docstring \e$B9g$C$F$k!)\e(B
+
(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)
projects / elisp / lemi.git / commitdiff