src/pcl/fixup.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3
   4 ;;;; This software is derived from software originally released by Xerox
   5 ;;;; Corporation. Copyright and release statements follow. Later modifications
   6 ;;;; to the software are in the public domain and are provided with
   7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
   8 ;;;; information.
   9
  10 ;;;; copyright information from original PCL sources:
  11 ;;;;
  12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  13 ;;;; All rights reserved.
  14 ;;;;
  15 ;;;; Use and copying of this software and preparation of derivative works based
  16 ;;;; upon this software are permitted. Any distribution of this software or
  17 ;;;; derivative works must comply with all applicable United States export
  18 ;;;; control laws.
  19 ;;;;
  20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  21 ;;;; warranty about the software, its performance or its conformity to any
  22 ;;;; specification.
  23
  24 (in-package "SB-PCL")
  25
  26 (!fix-early-generic-functions)
  27
  28 (fmakunbound 'ensure-accessor)
  29 (defun ensure-accessor (fun-name) ; Make FUN-NAME exist as a GF if it doesn't
  30   (destructuring-bind (slot-name method) (cddr fun-name)
  31     ;; FIXME: change SLOT-OBJECT here to T to get SLOT-MISSING
  32     ;; behaviour for non-slot-objects too?
  33     (let ((reader-specializers (load-time-value (list (find-class 'slot-object)) t))
  34           (writer-specializers (load-time-value (list (find-class 't)
  35                                                       (find-class 'slot-object)) t)))
  36       (multiple-value-bind (lambda-list specializers method-class initargs doc)
  37           (ecase method
  38             (reader
  39              (values '(object) reader-specializers 'global-reader-method
  40                      (make-std-reader-method-function 'slot-object slot-name)
  41                      "automatically-generated reader method"))
  42             (writer
  43              (values '(new-value object) writer-specializers
  44                      'global-writer-method
  45                      (make-std-writer-method-function 'slot-object slot-name)
  46                      "automatically-generated writer method"))
  47             (boundp
  48              (values '(object) reader-specializers 'global-boundp-method
  49                      (make-std-boundp-method-function 'slot-object slot-name)
  50                      "automatically-generated boundp method")))
  51         (let ((gf (ensure-generic-function fun-name :lambda-list lambda-list)))
  52           (add-method gf (make-a-method method-class
  53                                         () lambda-list specializers
  54                                         initargs doc :slot-name slot-name)))))))
  55
  56 (dolist (gf-name *!temporary-ensure-accessor-functions*)
  57   ; (format t "~&Genericizing ~S~%" gf-name)
  58   (fmakunbound gf-name)
  59   (ensure-accessor gf-name))
  60
  61 (compute-standard-slot-locations)
  62 (dolist (s '(condition function structure-object))
  63   (dohash ((k v) (classoid-subclasses (find-classoid s)))
  64     (declare (ignore v))
  65     (find-class (classoid-name k))))
  66 (setq **boot-state** 'complete)
  67
  68 ;;; CLASS-PROTOTYPE for FUNCTION should not use ALLOCATE-INSTANCE.
  69 (let ((class (find-class 'function)))
  70   (setf (slot-value class 'prototype) #'identity))