src/pcl/construct.lisp

   1 ;;;; This file defines MAKE-INSTANCE optimization mechanisms.
   2 ;;;;
   3 ;;;; KLUDGE: I removed the old DEFCONSTRUCTOR, MAKE-CONSTRUCTOR, and
   4 ;;;; LOAD-CONSTRUCTOR families of definitions in sbcl-0.pre7.99, since
   5 ;;;; it was clear from a few minutes with egrep that they were dead
   6 ;;;; code, but I suspect more dead code remains in this file. (Maybe
   7 ;;;; it's all dead?) -- WHN 2001-12-26
   8
   9 ;;;; This software is part of the SBCL system. See the README file for
  10 ;;;; more information.
  11
  12 ;;;; This software is derived from software originally released by Xerox
  13 ;;;; Corporation. Copyright and release statements follow. Later modifications
  14 ;;;; to the software are in the public domain and are provided with
  15 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
  16 ;;;; information.
  17
  18 ;;;; copyright information from original PCL sources:
  19 ;;;;
  20 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  21 ;;;; All rights reserved.
  22 ;;;;
  23 ;;;; Use and copying of this software and preparation of derivative works based
  24 ;;;; upon this software are permitted. Any distribution of this software or
  25 ;;;; derivative works must comply with all applicable United States export
  26 ;;;; control laws.
  27 ;;;;
  28 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  29 ;;;; warranty about the software, its performance or its conformity to any
  30 ;;;; specification.
  31
  32 (in-package "SB-PCL")
  33 \f
  34 ;;; The actual constructor objects.
  35 (defclass constructor (funcallable-standard-object)
  36      ((class                                    ;The class with which this
  37         :initarg :class                         ;constructor is associated.
  38         :reader constructor-class)              ;The actual class object,
  39                                                 ;not the class name.
  40
  41       (name                                     ;The name of this constructor.
  42         :initform nil                           ;This is the symbol in whose
  43         :initarg :name                          ;function cell the constructor
  44         :reader constructor-name)               ;usually sits. Of course, this
  45                                                 ;is optional. The old
  46                                                 ;DEFCONSTRUCTOR macro made
  47                                                 ;named constructors, but
  48                                                 ;it is possible to manipulate
  49                                                 ;anonymous constructors also.
  50
  51       (supplied-initarg-names                   ;The names of the initargs this
  52         :initarg :supplied-initarg-names        ;constructor supplies when it
  53         :reader                                 ;"calls" make-instance.
  54            constructor-supplied-initarg-names)  ;
  55
  56       (code-generators                          ;Generators for the different
  57         :initarg :code-generators               ;types of code this constructor
  58         :reader constructor-code-generators))   ;could use.
  59   (:metaclass funcallable-standard-class))
  60
  61 (defmethod describe-object ((constructor constructor) stream)
  62   (format stream
  63           "~S is a constructor for the class ~S.~%"
  64           constructor (constructor-class constructor)))
  65 \f
  66 ;;;; Here is the actual smarts for making the code generators and then
  67 ;;;; trying each generator to get constructor code. This extensible
  68 ;;;; mechanism allows new kinds of constructor code types to be added.
  69 ;;;; A programmer defining a specialization of the constructor class
  70 ;;;; can use this mechanism to define new code types.
  71 ;;;;
  72 ;;;; original PCL comment from before dead COMPUTE-CONSTRUCTOR-CODE
  73 ;;;; was deleted:
  74 ;;;;    When compute-constructor-code is called, it first performs
  75 ;;;;    basic checks to make sure that the basic assumptions common to
  76 ;;;;    all the code types are valid. (For details see method
  77 ;;;;    definition). If any of the tests fail, the fallback
  78 ;;;;    constructor code type is used. If none of the tests fail, the
  79 ;;;;    constructor code generators are called in order. They receive
  80 ;;;;    5 arguments:
  81 ;;;;
  82 ;;;;   CLASS    the class the constructor is making instances of
  83 ;;;;   WRAPPER      that class's wrapper
  84 ;;;;   DEFAULTS     the result of calling class-default-initargs on class
  85 ;;;;   INITIALIZE   the applicable methods on initialize-instance
  86 ;;;;   SHARED       the applicable methosd on shared-initialize
  87 ;;;;
  88 ;;;; The first code generator to return code is used. The code
  89 ;;;; generators are called in reverse order of definition, so forms
  90 ;;;; which define better code should appear after ones that define
  91 ;;;; less good code. The fallback code type appears first. Note that
  92 ;;;; redefining a code type does not change its position in the list.
  93 ;;;; To do that, define a new type at the end with the behavior.
  94 \f
  95 ;;;; helper functions and utilities that are shared by all of the code
  96 ;;;; types
  97
  98 (defvar *standard-initialize-instance-method*
  99         (get-method #'initialize-instance
 100                     ()
 101                     (list *the-class-slot-object*)))
 102
 103 (defvar *standard-shared-initialize-method*
 104         (get-method #'shared-initialize
 105                     ()
 106                     (list *the-class-slot-object* *the-class-t*)))
 107
 108 (defun non-pcl-initialize-instance-methods-p (methods)
 109   (notevery #'(lambda (m) (eq m *standard-initialize-instance-method*))
 110             methods))
 111
 112 (defun non-pcl-shared-initialize-methods-p (methods)
 113   (notevery #'(lambda (m) (eq m *standard-shared-initialize-method*))
 114             methods))
 115
 116 (defun non-pcl-or-after-initialize-instance-methods-p (methods)
 117   (notevery #'(lambda (m) (or (eq m *standard-initialize-instance-method*)
 118                               (equal '(:after) (method-qualifiers m))))
 119             methods))
 120
 121 (defun non-pcl-or-after-shared-initialize-methods-p (methods)
 122   (notevery #'(lambda (m) (or (eq m *standard-shared-initialize-method*)
 123                               (equal '(:after) (method-qualifiers m))))
 124             methods))