73 lines
3.8 KiB
Common Lisp
73 lines
3.8 KiB
Common Lisp
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
|
|
|
;;;. Copyright (c) 1991 by Venue
|
|
|
|
|
|
(in-package "CLOS")
|
|
|
|
|
|
;;; This file contains the
|
|
;;; definition of the FUNCALLABLE-STANDARD-CLASS metaclass. Much of the implementation of this
|
|
;;; metaclass is actually defined on the class STD-CLASS. What appears in this file is a modest
|
|
;;; number of simple methods related to the low-level differences in the implementation of standard
|
|
;;; and funcallable-standard instances. As it happens, none of these differences are the ones
|
|
;;; reflected in the MOP specification; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS share all
|
|
;;; their specified methods at STD-CLASS. workings of this metaclass and the standard-class
|
|
;;; metaclass.
|
|
|
|
|
|
(defmethod wrapper-fetcher ((class funcallable-standard-class))
|
|
'fsc-instance-wrapper)
|
|
|
|
(defmethod slots-fetcher ((class funcallable-standard-class))
|
|
'fsc-instance-slots)
|
|
|
|
(defmethod raw-instance-allocator ((class funcallable-standard-class))
|
|
'allocate-funcallable-instance-1)
|
|
|
|
|
|
;;;
|
|
|
|
|
|
(defmethod check-super-metaclass-compatibility ((fsc funcallable-standard-class)
|
|
(class standard-class))
|
|
(null (wrapper-instance-slots-layout (class-wrapper class))))
|
|
|
|
(defmethod allocate-instance ((class funcallable-standard-class)
|
|
&rest initargs)
|
|
(declare (ignore initargs))
|
|
(unless (class-finalized-p class)
|
|
(finalize-inheritance class))
|
|
(let ((class-wrapper (class-wrapper class)))
|
|
(allocate-funcallable-instance class-wrapper (class-no-of-instance-slots class))))
|
|
|
|
(defmethod make-reader-method-function ((class funcallable-standard-class)
|
|
slot-name)
|
|
(make-std-reader-method-function slot-name))
|
|
|
|
(defmethod make-writer-method-function ((class funcallable-standard-class)
|
|
slot-name)
|
|
(make-std-writer-method-function slot-name))
|
|
|
|
; See the comment about
|
|
; reader-function--std and
|
|
; writer-function--sdt.
|
|
; (define-function-template
|
|
; reader-function--fsc () '(slot-name)
|
|
; `(function (lambda (instance)
|
|
; (slot-value-using-class
|
|
; (wrapper-class (get-wrapper
|
|
; instance)) instance slot-name))))
|
|
; (define-function-template
|
|
; writer-function--fsc () '(slot-name)
|
|
; `(function (lambda (nv instance)
|
|
; (setf (slot-value-using-class
|
|
; (wrapper-class (get-wrapper
|
|
; instance)) instance slot-name) nv))))
|
|
; (eval-when (load)
|
|
; (pre-make-templated-function-constructor
|
|
; reader-function--fsc)
|
|
; (pre-make-templated-function-constructor
|
|
; writer-function--fsc))
|
|
|