(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
(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)
(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."
(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)
)))
(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.
(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.
(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)
"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)
(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)
projects / elisp / flim.git / blobdiff