src/pcl/fsc.lisp

   1 ;;;; This file contains the definition of the FUNCALLABLE-STANDARD-CLASS
   2 ;;;; metaclass. Much of the implementation of this metaclass is actually
   3 ;;;; defined on the class STD-CLASS. What appears in this file is a modest
   4 ;;;; number of simple methods related to the low-level differences in the
   5 ;;;; implementation of standard and funcallable-standard instances.
   6 ;;;;
   7 ;;;; As it happens, none of these differences are the ones reflected in
   8 ;;;; the MOP specification; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS
   9 ;;;; share all their specified methods at STD-CLASS.
  10
  11 ;;;; This software is part of the SBCL system. See the README file for
  12 ;;;; more information.
  13
  14 ;;;; This software is derived from software originally released by Xerox
  15 ;;;; Corporation. Copyright and release statements follow. Later modifications
  16 ;;;; to the software are in the public domain and are provided with
  17 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
  18 ;;;; information.
  19
  20 ;;;; copyright information from original PCL sources:
  21 ;;;;
  22 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  23 ;;;; All rights reserved.
  24 ;;;;
  25 ;;;; Use and copying of this software and preparation of derivative works based
  26 ;;;; upon this software are permitted. Any distribution of this software or
  27 ;;;; derivative works must comply with all applicable United States export
  28 ;;;; control laws.
  29 ;;;;
  30 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  31 ;;;; warranty about the software, its performance or its conformity to any
  32 ;;;; specification.
  33
  34 (in-package "SB-PCL")
  35
  36 (sb-int:file-comment
  37   "$Header$")
  38 \f
  39 (defmethod wrapper-fetcher ((class funcallable-standard-class))
  40   'fsc-instance-wrapper)
  41
  42 (defmethod slots-fetcher ((class funcallable-standard-class))
  43   'fsc-instance-slots)
  44
  45 (defmethod raw-instance-allocator ((class funcallable-standard-class))
  46   'allocate-funcallable-instance)
  47
  48 (defmethod validate-superclass ((fsc funcallable-standard-class)
  49                                 (new-super std-class))
  50   (let ((new-super-meta-class (class-of new-super)))
  51     (or (eq new-super-meta-class *the-class-std-class*)
  52         (eq (class-of fsc) new-super-meta-class))))
  53
  54 (defmethod allocate-instance
  55            ((class funcallable-standard-class) &rest initargs)
  56   (declare (ignore initargs))
  57   (unless (class-finalized-p class) (finalize-inheritance class))
  58   (allocate-funcallable-instance (class-wrapper class)))
  59
  60 (defmethod make-reader-method-function ((class funcallable-standard-class)
  61                                         slot-name)
  62   (make-std-reader-method-function (class-name class) slot-name))
  63
  64 (defmethod make-writer-method-function ((class funcallable-standard-class)
  65                                         slot-name)
  66   (make-std-writer-method-function (class-name class) slot-name))
  67
  68 ;;;; See the comment about reader-function--std and writer-function--sdt.
  69 ;;;;
  70 ;(define-function-template reader-function--fsc () '(slot-name)
  71 ;  `(function
  72 ;     (lambda (instance)
  73 ;       (slot-value-using-class (wrapper-class (get-wrapper instance))
  74 ;                              instance
  75 ;                              slot-name))))
  76 ;
  77 ;(define-function-template writer-function--fsc () '(slot-name)
  78 ;  `(function
  79 ;     (lambda (nv instance)
  80 ;       (setf
  81 ;        (slot-value-using-class (wrapper-class (get-wrapper instance))
  82 ;                                instance
  83 ;                                slot-name)
  84 ;        nv))))
  85 ;
  86 ;(eval-when (:load-toplevel)
  87 ;  (pre-make-templated-function-constructor reader-function--fsc)
  88 ;  (pre-make-templated-function-constructor writer-function--fsc))