;;; luna.el --- tiny OOP system kernel
;; Copyright (C) 1999 Electrotechnical Laboratory, JAPAN.
+;; Licensed to the Free Software Foundation.
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
;; Keywords: OOP
(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)))
+
(defmacro luna-find-class (name)
"Return the luna-class of the given NAME."
`(get ,name '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))
+
+(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
- (i 2))
+ (i 2)
+ b j)
(while rest
- (setq parent (pop rest))
+ (setq parent (pop rest)
+ b (- i 2))
(mapatoms (lambda (sym)
- (when (get sym 'luna-member-index)
+ (when (setq j (get sym 'luna-slot-index))
(setq name (symbol-name sym))
(unless (intern-soft name oa)
- (put (intern name oa) 'luna-member-index i)
+ (put (intern name oa) 'luna-slot-index (+ j b))
(setq i (1+ i))
)))
(luna-class-obarray (luna-find-class parent)))
(while rest
(setq name (symbol-name (pop rest)))
(unless (intern-soft name oa)
- (put (intern name oa) 'luna-member-index i)
+ (put (intern name oa) 'luna-slot-index i)
(setq i (1+ i))
))
- `(luna-set-class ',type
- (vector 'class ,oa ',parents ,i))
+ (luna-set-class type (vector 'class oa parents i))
))
-(defmacro luna-class-name (entity)
- "Return class-name of the ENTITY."
- `(aref ,entity 0))
-
-(defmacro luna-set-class-name (entity name)
- `(aset ,entity 0 ,name))
-
-(defmacro luna-get-obarray (entity)
- `(aref ,entity 1))
-
-(defmacro luna-set-obarray (entity obarray)
- `(aset ,entity 1 ,obarray))
-
-(defmacro 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 `:'."
- `(apply #'luna-make-entity-function ',type ',init-args))
-
-(defsubst luna-make-entity-function (type &rest init-args)
- (let* ((c (get type 'luna-class))
- (v (make-vector (luna-class-number-of-slots c) nil))
- (oa (luna-class-obarray c))
- s i)
- (luna-set-class-name v type)
- (luna-set-obarray v (make-vector 7 0))
- (while init-args
- (setq s (intern-soft (substring (symbol-name (pop init-args)) 1) oa)
- i (pop init-args))
- (if s
- (aset v (get s 'luna-member-index) i)
- ))
- v))
-
-(defsubst luna-class-find-member (class member-name)
+(defun luna-class-find-member (class member-name)
(or (stringp member-name)
(setq member-name (symbol-name member-name)))
(or (intern-soft member-name (luna-class-obarray class))
(intern member-name (luna-class-obarray class)))
(defmacro luna-class-slot-index (class slot-name)
- `(get (luna-class-find-member ,class ,slot-name) 'luna-member-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))
"Store VALUE into SLOT of ENTITY."
(aset entity (luna-slot-index entity slot) value))
-(defmacro luna-define-method (name args &rest body)
- "Define NAME as a method function of (nth 1 (car ARGS)) backend.
+(defmacro luna-define-method (name &rest definition)
+ "Define NAME as a method function of a class.
+
+Usage of this macro follows:
+
+ (luna-define-method NAME [METHOD-QUALIFIER] ARGLIST [DOCSTRING] BODY...)
+
+NAME is the name of method.
+
+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.
+
+Optional argument DOCSTRING is the documentation of method.
-ARGS is like an argument list of lambda, but (car ARGS) must be
-specialized parameter. (car (car ARGS)) is name of variable and (nth
-1 (car ARGS)) is name of backend."
- (let* ((specializer (car args))
- (class (nth 1 specializer))
- (self (car specializer)))
+BODY is the body of method."
+ (let ((method-qualifier (pop definition))
+ args specializer class self)
+ (if (memq method-qualifier '(:before :after :around))
+ (setq args (pop definition))
+ (setq args method-qualifier
+ method-qualifier nil)
+ )
+ (setq specializer (car args)
+ class (nth 1 specializer)
+ self (car specializer))
`(let ((func (lambda ,(if self
(cons self (cdr args))
(cdr args))
- ,@body)))
- (fset (luna-class-find-or-make-member (luna-find-class ',class) ',name)
- func))))
+ ,@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)
-(defsubst luna-class-find-function (class service)
+(def-edebug-spec luna-define-method
+ (&define name [&optional &or ":before" ":after" ":around"]
+ ((arg symbolp)
+ [&rest arg]
+ [&optional ["&optional" arg &rest arg]]
+ &optional ["&rest" arg]
+ )
+ def-body))
+
+(defun luna-class-find-parents-functions (class service)
+ (let ((parents (luna-class-parents class))
+ ret)
+ (while (and parents
+ (null
+ (setq ret (luna-class-find-functions
+ (luna-find-class (pop parents))
+ service)))))
+ ret))
+
+(defun luna-class-find-functions (class service)
(let ((sym (luna-class-find-member class service)))
(if (fboundp sym)
- (symbol-function sym)
- (let ((parents (luna-class-parents class))
- ret)
- (while (and parents
- (null
- (setq ret (luna-class-find-function
- (luna-find-class (pop parents))
- service)))))
- ret))))
+ (cond ((eq (get sym 'luna-method-qualifier) :before)
+ (cons (symbol-function sym)
+ (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)))
+ )
+ ((eq (get sym 'luna-method-qualifier) :around)
+ (cons sym (luna-class-find-parents-functions class service))
+ )
+ (t
+ (list (symbol-function sym))
+ ))
+ (luna-class-find-parents-functions class service)
+ )))
+
+(defmacro luna-find-functions (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.
+LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE."
+ (let ((luna-next-methods (luna-find-functions entity message))
+ luna-current-method
+ luna-previous-return-value)
+ (while (and luna-next-methods
+ (progn
+ (setq luna-current-method (pop luna-next-methods)
+ luna-previous-return-value
+ (apply luna-current-method
+ luna-current-method-arguments))
+ (if (symbolp luna-current-method)
+ (not (eq (get luna-current-method
+ 'luna-method-qualifier) :around))
+ t))))
+ luna-previous-return-value))
+
+(eval-when-compile
+ (defvar luna-next-methods nil)
+ (defvar luna-current-method-arguments nil)
+ )
+
+(defun luna-call-next-method ()
+ "Call the next method in a method with :around qualifier."
+ (let (luna-current-method
+ luna-previous-return-value)
+ (while (and luna-next-methods
+ (progn
+ (setq luna-current-method (pop luna-next-methods)
+ luna-previous-return-value
+ (apply luna-current-method
+ luna-current-method-arguments))
+ (if (symbolp luna-current-method)
+ (not (eq (get luna-current-method
+ 'luna-method-qualifier) :around))
+ t))))
+ luna-previous-return-value))
+
+(defmacro luna-class-name (entity)
+ "Return class-name of the ENTITY."
+ `(aref ,entity 0))
+
+(defmacro luna-set-class-name (entity name)
+ `(aset ,entity 0 ,name))
+
+(defmacro luna-get-obarray (entity)
+ `(aref ,entity 1))
-(defmacro luna-find-function (entity service)
- `(luna-class-find-function (luna-find-class (luna-class-name ,entity))
- ,service))
+(defmacro luna-set-obarray (entity obarray)
+ `(aset ,entity 1 ,obarray))
-(defsubst luna-send (entity message &rest args)
- "Send MESSAGE to ENTITY with ARGS, and return the result."
- (apply (luna-find-function entity message)
- entity args))
+(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))
+ (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)
+ ))
(defsubst luna-arglist-to-arguments (arglist)
(let (dest)
`(defun ,(intern (symbol-name name)) ,args
,doc
(luna-send ,(car args) ',name
- ,@(luna-arglist-to-arguments (cdr args)))
+ ,@(luna-arglist-to-arguments args))
)
`(defun ,(intern (symbol-name name)) ,args
(luna-send ,(car args) ',name
- ,@(luna-arglist-to-arguments (cdr args)))
+ ,@(luna-arglist-to-arguments args))
)))
(put 'luna-define-generic 'lisp-indent-function 'defun)
+(defun luna-define-internal-accessors (class-name)
+ "Define internal accessors for an entity of CLASS-NAME."
+ (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))
+ ))
+ )))
+ (luna-class-obarray entity-class))))
+
+(luna-define-class-function 'standard-object)
+
+(luna-define-method initialize-instance ((entity standard-object)
+ &rest init-args)
+ (let* ((c (luna-find-class (luna-class-name entity)))
+ (oa (luna-class-obarray c))
+ s i)
+ (while init-args
+ (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)
+ ))
+ entity))
+
;;; @ end
;;;
projects / elisp / flim.git / blobdiff