luna.el

   1 ;;; luna.el --- tiny OOP system kernel
   2
   3 ;; Copyright (C) 1999,2000 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
   6 ;; Keywords: OOP
   7
   8 ;; This file is part of FLIM (Faithful Library about Internet Message).
   9
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 (eval-when-compile (require 'cl))
  28
  29
  30 ;;; @ class
  31 ;;;
  32
  33 (defmacro luna-find-class (name)
  34   "Return the luna-class of the given NAME."
  35   `(get ,name 'luna-class))
  36
  37 (defmacro luna-set-class (name class)
  38   `(put ,name 'luna-class ,class))
  39
  40 (defmacro luna-class-obarray (class)
  41   `(aref ,class 1))
  42
  43 (defmacro luna-class-parents (class)
  44   `(aref ,class 2))
  45
  46 (defmacro luna-class-number-of-slots (class)
  47   `(aref ,class 3))
  48
  49 (defmacro luna-define-class (type &optional parents slots)
  50   "Define TYPE as a luna-class.
  51 If PARENTS is specified, TYPE inherits PARENTS.
  52 Each parent must be name of luna-class (symbol).
  53 If SLOTS is specified, TYPE will be defined to have them."
  54   `(luna-define-class-function ',type ',(append parents '(standard-object))
  55                                ',slots))
  56
  57 (defun luna-define-class-function (type &optional parents slots)
  58   (let ((oa (make-vector 31 0))
  59         (rest parents)
  60         parent name
  61         (i 2)
  62         b j)
  63     (while rest
  64       (setq parent (pop rest)
  65             b (- i 2))
  66       (mapatoms (lambda (sym)
  67                   (when (setq j (get sym 'luna-slot-index))
  68                     (setq name (symbol-name sym))
  69                     (unless (intern-soft name oa)
  70                       (put (intern name oa) 'luna-slot-index (+ j b))
  71                       (setq i (1+ i)))))
  72                 (luna-class-obarray (luna-find-class parent))))
  73     (setq rest slots)
  74     (while rest
  75       (setq name (symbol-name (pop rest)))
  76       (unless (intern-soft name oa)
  77         (put (intern name oa) 'luna-slot-index i)
  78         (setq i (1+ i))))
  79     (luna-set-class type (vector 'class oa parents i))))
  80
  81 (defun luna-class-find-member (class member-name)
  82   (or (stringp member-name)
  83       (setq member-name (symbol-name member-name)))
  84   (or (intern-soft member-name (luna-class-obarray class))
  85       (let ((parents (luna-class-parents class))
  86             ret)
  87         (while (and parents
  88                     (null
  89                      (setq ret (luna-class-find-member
  90                                 (luna-find-class (pop parents))
  91                                 member-name)))))
  92         ret)))
  93
  94 (defsubst luna-class-find-or-make-member (class member-name)
  95   (or (stringp member-name)
  96       (setq member-name (symbol-name member-name)))
  97   (intern member-name (luna-class-obarray class)))
  98
  99 (defmacro luna-class-slot-index (class slot-name)
 100   `(get (luna-class-find-member ,class ,slot-name) 'luna-slot-index))
 101
 102 (defmacro luna-define-method (name &rest definition)
 103   "Define NAME as a method function of a class.
 104
 105 Usage of this macro follows:
 106
 107   (luna-define-method NAME [METHOD-QUALIFIER] ARGLIST [DOCSTRING] BODY...)
 108
 109 NAME is the name of method.
 110
 111 Optional argument METHOD-QUALIFIER must be :before, :after or :around.
 112 If it is :before / :after, the method is called before / after a
 113 method of parent class is finished.  ARGLIST is like an argument list
 114 of lambda, but (car ARGLIST) must be specialized parameter.  (car (car
 115 ARGLIST)) is name of variable and \(nth 1 (car ARGLIST)) is name of
 116 class.
 117
 118 Optional argument DOCSTRING is the documentation of method.
 119
 120 BODY is the body of method."
 121   (let ((method-qualifier (pop definition))
 122         args specializer class self)
 123     (if (memq method-qualifier '(:before :after :around))
 124         (setq args (pop definition))
 125       (setq args method-qualifier
 126             method-qualifier nil))
 127     (setq specializer (car args)
 128           class (nth 1 specializer)
 129           self (car specializer))
 130     `(let ((func (lambda ,(if self
 131                               (cons self (cdr args))
 132                             (cdr args))
 133                    ,@definition))
 134            (sym (luna-class-find-or-make-member
 135                  (luna-find-class ',class) ',name))
 136            (cache (get ',name 'luna-method-cache)))
 137        (if cache
 138            (unintern ',class cache))
 139        (fset sym func)
 140        (put sym 'luna-method-qualifier ,method-qualifier))))
 141
 142 (put 'luna-define-method 'lisp-indent-function 'defun)
 143
 144 (def-edebug-spec luna-define-method
 145   (&define name [&optional &or ":before" ":after" ":around"]
 146            ((arg symbolp)
 147             [&rest arg]
 148             [&optional ["&optional" arg &rest arg]]
 149             &optional ["&rest" arg])
 150            def-body))
 151
 152 (defun luna-class-find-parents-functions (class service)
 153   (let ((parents (luna-class-parents class))
 154         ret)
 155     (while (and parents
 156                 (null
 157                  (setq ret (luna-class-find-functions
 158                             (luna-find-class (pop parents))
 159                             service)))))
 160     ret))
 161
 162 (defun luna-class-find-functions (class service)
 163   (let ((sym (luna-class-find-member class service)))
 164     (if (fboundp sym)
 165         (cond ((eq (get sym 'luna-method-qualifier) :before)
 166                (cons (symbol-function sym)
 167                      (luna-class-find-parents-functions class service)))
 168               ((eq (get sym 'luna-method-qualifier) :after)
 169                (nconc (luna-class-find-parents-functions class service)
 170                       (list (symbol-function sym))))
 171               ((eq (get sym 'luna-method-qualifier) :around)
 172                (cons sym (luna-class-find-parents-functions class service)))
 173               (t
 174                (list (symbol-function sym))))
 175       (luna-class-find-parents-functions class service))))
 176
 177
 178 ;;; @ instance (entity)
 179 ;;;
 180
 181 (defmacro luna-class-name (entity)
 182   "Return class-name of the ENTITY."
 183   `(aref ,entity 0))
 184
 185 (defmacro luna-set-class-name (entity name)
 186   `(aset ,entity 0 ,name))
 187
 188 (defmacro luna-get-obarray (entity)
 189   `(aref ,entity 1))
 190
 191 (defmacro luna-set-obarray (entity obarray)
 192   `(aset ,entity 1 ,obarray))
 193
 194 (defmacro luna-slot-index (entity slot-name)
 195   `(luna-class-slot-index (luna-find-class (luna-class-name ,entity))
 196                           ,slot-name))
 197
 198 (defsubst luna-slot-value (entity slot)
 199   "Return the value of SLOT of ENTITY."
 200   (aref entity (luna-slot-index entity slot)))
 201
 202 (defsubst luna-set-slot-value (entity slot value)
 203   "Store VALUE into SLOT of ENTITY."
 204   (aset entity (luna-slot-index entity slot) value))
 205
 206 (defmacro luna-find-functions (entity service)
 207   `(luna-class-find-functions (luna-find-class (luna-class-name ,entity))
 208                               ,service))
 209
 210 (defsubst luna-send (entity message &rest luna-current-method-arguments)
 211   "Send MESSAGE to ENTITY, and return the result.
 212 LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE."
 213   (let ((luna-next-methods (luna-find-functions entity message))
 214         luna-current-method
 215         luna-previous-return-value)
 216     (while (and luna-next-methods
 217                 (progn
 218                   (setq luna-current-method (pop luna-next-methods)
 219                         luna-previous-return-value
 220                         (apply luna-current-method
 221                                luna-current-method-arguments))
 222                   (if (symbolp luna-current-method)
 223                       (not (eq (get luna-current-method
 224                                     'luna-method-qualifier) :around))
 225                     t))))
 226     luna-previous-return-value))
 227
 228 (eval-when-compile
 229   (defvar luna-next-methods nil)
 230   (defvar luna-current-method-arguments nil))
 231
 232 (defun luna-call-next-method ()
 233   "Call the next method in a method with :around qualifier."
 234   (let (luna-current-method
 235         luna-previous-return-value)
 236     (while (and luna-next-methods
 237                 (progn
 238                   (setq luna-current-method (pop luna-next-methods)
 239                         luna-previous-return-value
 240                         (apply luna-current-method
 241                                luna-current-method-arguments))
 242                   (if (symbolp luna-current-method)
 243                       (not (eq (get luna-current-method
 244                                     'luna-method-qualifier) :around))
 245                     t))))
 246     luna-previous-return-value))
 247
 248 (defun luna-make-entity (type &rest init-args)
 249   "Make instance of luna-class TYPE and return it.
 250 If INIT-ARGS is specified, it is used as initial values of the slots.
 251 It must be plist and each slot name must have prefix `:'."
 252   (let* ((c (get type 'luna-class))
 253          (v (make-vector (luna-class-number-of-slots c) nil)))
 254     (luna-set-class-name v type)
 255     (luna-set-obarray v (make-vector 7 0))
 256     (apply #'luna-send v 'initialize-instance v init-args)))
 257
 258
 259 ;;; @ interface (generic function)
 260 ;;;
 261
 262 (defun luna-apply-generic (entity message &rest luna-current-method-arguments)
 263   (let* ((class (luna-class-name entity))
 264          (cache (get message 'luna-method-cache))
 265          (sym (intern-soft (symbol-name class) cache))
 266          luna-next-methods)
 267     (if sym
 268         (setq luna-next-methods (symbol-value sym))
 269       (setq luna-next-methods
 270             (luna-find-functions entity message))
 271       (set (intern (symbol-name class) cache)
 272            luna-next-methods))
 273     (luna-call-next-method)))
 274
 275 (defsubst luna-arglist-to-arguments (arglist)
 276   (let (dest)
 277     (while arglist
 278       (let ((arg (car arglist)))
 279         (or (memq arg '(&optional &rest))
 280             (setq dest (cons arg dest))))
 281       (setq arglist (cdr arglist)))
 282     (nreverse dest)))
 283
 284 (defmacro luna-define-generic (name args &optional doc)
 285   "Define generic-function NAME.
 286 ARGS is argument of and DOC is DOC-string."
 287   (if doc
 288       `(progn
 289          (defun ,(intern (symbol-name name)) ,args
 290            ,doc
 291            (luna-apply-generic ,(car args) ',name
 292                                ,@(luna-arglist-to-arguments args)))
 293          (put ',name 'luna-method-cache (make-vector 31 0)))
 294     `(progn
 295        (defun ,(intern (symbol-name name)) ,args
 296          (luna-apply-generic ,(car args) ',name
 297                              ,@(luna-arglist-to-arguments args)))
 298        (put ',name 'luna-method-cache (make-vector 31 0)))))
 299
 300 (put 'luna-define-generic 'lisp-indent-function 'defun)
 301
 302
 303 ;;; @ accessor
 304 ;;;
 305
 306 (defun luna-define-internal-accessors (class-name)
 307   "Define internal accessors for an entity of CLASS-NAME."
 308   (let ((entity-class (luna-find-class class-name))
 309         parents parent-class)
 310     (mapatoms
 311      (lambda (slot)
 312        (if (luna-class-slot-index entity-class slot)
 313            (catch 'derived
 314              (setq parents (luna-class-parents entity-class))
 315              (while parents
 316                (setq parent-class (luna-find-class (car parents)))
 317                (if (luna-class-slot-index parent-class slot)
 318                    (throw 'derived nil))
 319                (setq parents (cdr parents)))
 320              (eval
 321               `(progn
 322                  (defmacro ,(intern (format "%s-%s-internal"
 323                                             class-name slot))
 324                    (entity)
 325                    (list 'aref entity
 326                          ,(luna-class-slot-index entity-class
 327                                                  (intern (symbol-name slot)))))
 328                  (defmacro ,(intern (format "%s-set-%s-internal"
 329                                             class-name slot))
 330                    (entity value)
 331                    (list 'aset entity
 332                          ,(luna-class-slot-index
 333                            entity-class (intern (symbol-name slot)))
 334                          value)))))))
 335      (luna-class-obarray entity-class))))
 336
 337
 338 ;;; @ standard object
 339 ;;;
 340
 341 (luna-define-class-function 'standard-object)
 342
 343 (luna-define-method initialize-instance ((entity standard-object)
 344                                          &rest init-args)
 345   (let* ((c (luna-find-class (luna-class-name entity)))
 346          (oa (luna-class-obarray c))
 347          s i)
 348     (while init-args
 349       (setq s (intern-soft (substring (symbol-name (pop init-args)) 1) oa)
 350             i (pop init-args))
 351       (if s
 352           (aset entity (get s 'luna-slot-index) i)))
 353     entity))
 354
 355
 356 ;;; @ end
 357 ;;;
 358
 359 (provide 'luna)
 360
 361 ;; luna.el ends here