src/pcl/env.lisp

   1 ;;;; basic environmental stuff
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5
   6 ;;;; This software is derived from software originally released by Xerox
   7 ;;;; Corporation. Copyright and release statements follow. Later modifications
   8 ;;;; to the software are in the public domain and are provided with
   9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
  10 ;;;; information.
  11
  12 ;;;; copyright information from original PCL sources:
  13 ;;;;
  14 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  15 ;;;; All rights reserved.
  16 ;;;;
  17 ;;;; Use and copying of this software and preparation of derivative works based
  18 ;;;; upon this software are permitted. Any distribution of this software or
  19 ;;;; derivative works must comply with all applicable United States export
  20 ;;;; control laws.
  21 ;;;;
  22 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  23 ;;;; warranty about the software, its performance or its conformity to any
  24 ;;;; specification.
  25
  26 (in-package "SB-PCL")
  27
  28 (sb-int:file-comment
  29   "$Header$")
  30 \f
  31 ;;; FIXME: This stuff isn't part of the ANSI spec, and isn't even
  32 ;;; exported from PCL, but it looks as though it might be useful,
  33 ;;; so I don't want to just delete it. Perhaps it should go in
  34 ;;; a contrib/ directory eventually?
  35
  36 #|
  37 ;;; TRACE-METHOD and UNTRACE-METHOD accept method specs as arguments. A
  38 ;;; method-spec should be a list like:
  39 ;;;   (<generic-function-spec> qualifiers* (specializers*))
  40 ;;; where <generic-function-spec> should be either a symbol or a list
  41 ;;; of (SETF <symbol>).
  42 ;;;
  43 ;;;   For example, to trace the method defined by:
  44 ;;;
  45 ;;;     (defmethod foo ((x spaceship)) 'ss)
  46 ;;;
  47 ;;;   You should say:
  48 ;;;
  49 ;;;     (trace-method '(foo (spaceship)))
  50 ;;;
  51 ;;;   You can also provide a method object in the place of the method
  52 ;;;   spec, in which case that method object will be traced.
  53 ;;;
  54 ;;; For untrace-method, if an argument is given, that method is untraced.
  55 ;;; If no argument is given, all traced methods are untraced.
  56 (defclass traced-method (method)
  57      ((method :initarg :method)
  58       (function :initarg :function
  59                 :reader method-function)
  60       (generic-function :initform nil
  61                         :accessor method-generic-function)))
  62
  63 (defmethod method-lambda-list ((m traced-method))
  64   (with-slots (method) m (method-lambda-list method)))
  65
  66 (defmethod method-specializers ((m traced-method))
  67   (with-slots (method) m (method-specializers method)))
  68
  69 (defmethod method-qualifiers ((m traced-method))
  70   (with-slots (method) m (method-qualifiers method)))
  71
  72 (defmethod accessor-method-slot-name ((m traced-method))
  73   (with-slots (method) m (accessor-method-slot-name method)))
  74
  75 (defvar *traced-methods* ())
  76
  77 (defun trace-method (spec &rest options)
  78   (multiple-value-bind (gf omethod name)
  79       (parse-method-or-spec spec)
  80     (let* ((tfunction (trace-method-internal (method-function omethod)
  81                                              name
  82                                              options))
  83            (tmethod (make-instance 'traced-method
  84                                    :method omethod
  85                                    :function tfunction)))
  86       (remove-method gf omethod)
  87       (add-method gf tmethod)
  88       (pushnew tmethod *traced-methods*)
  89       tmethod)))
  90
  91 (defun untrace-method (&optional spec)
  92   (flet ((untrace-1 (m)
  93            (let ((gf (method-generic-function m)))
  94              (when gf
  95                (remove-method gf m)
  96                (add-method gf (slot-value m 'method))
  97                (setq *traced-methods* (remove m *traced-methods*))))))
  98     (if (not (null spec))
  99         (multiple-value-bind (gf method)
 100             (parse-method-or-spec spec)
 101           (declare (ignore gf))
 102           (if (memq method *traced-methods*)
 103               (untrace-1 method)
 104               (error "~S is not a traced method?" method)))
 105         (dolist (m *traced-methods*) (untrace-1 m)))))
 106
 107 (defun trace-method-internal (ofunction name options)
 108   (eval `(untrace ,name))
 109   (setf (symbol-function name) ofunction)
 110   (eval `(trace ,name ,@options))
 111   (symbol-function name))
 112 |#
 113 \f
 114 ;(defun compile-method (spec)
 115 ;  (multiple-value-bind (gf method name)
 116 ;      (parse-method-or-spec spec)
 117 ;    (declare (ignore gf))
 118 ;    (compile name (method-function method))
 119 ;    (setf (method-function method) (symbol-function name))))
 120
 121 ;;; not used in SBCL
 122 #|
 123 (defmacro undefmethod (&rest args)
 124   (declare (arglist name {method-qualifier}* specializers))
 125   `(undefmethod-1 ',args))
 126
 127 (defun undefmethod-1 (args)
 128   (multiple-value-bind (gf method)
 129       (parse-method-or-spec args)
 130     (when (and gf method)
 131       (remove-method gf method)
 132       method)))
 133 |#
 134
 135 ;;; FIXME: Delete these.
 136 #|
 137 (pushnew :pcl *features*)
 138 (pushnew :portable-commonloops *features*)
 139 (pushnew :pcl-structures *features*)
 140 |#
 141
 142 ;;; FIXME: This was for some unclean bootstrapping thing we don't
 143 ;;; need in SBCL, right? So we can delete it, right?
 144 ;;; #+cmu
 145 ;;; (when (find-package "OLD-PCL")
 146 ;;;   (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl))
 147 ;;;     (symbol-function 'sb-pcl::print-object)))
 148 \f
 149 ;;;; MAKE-LOAD-FORM
 150
 151 ;; Overwrite the old bootstrap non-generic MAKE-LOAD-FORM function with a
 152 ;; shiny new generic function.
 153 (fmakunbound 'make-load-form)
 154 (defgeneric make-load-form (object &optional environment))
 155
 156 ;; Link bootstrap-time how-to-dump-it information into the shiny new
 157 ;; CLOS system.
 158 (defmethod make-load-form ((obj sb-sys:structure!object)
 159                            &optional (env nil env-p))
 160   (if env-p
 161       (sb-sys:structure!object-make-load-form obj env)
 162       (sb-sys:structure!object-make-load-form obj)))
 163
 164 (defmethod make-load-form ((object wrapper) &optional env)
 165   (declare (ignore env))
 166   (let ((pname (sb-kernel:class-proper-name (sb-kernel:layout-class object))))
 167     (unless pname
 168       (error "can't dump wrapper for anonymous class:~%  ~S"
 169              (sb-kernel:layout-class object)))
 170     `(sb-kernel:class-layout (cl:find-class ',pname))))
 171 \f
 172 ;;;; The following are hacks to deal with CMU CL having two different CLASS
 173 ;;;; classes.
 174
 175 (defun coerce-to-pcl-class (class)
 176   (if (typep class 'cl:class)
 177       (or (sb-kernel:class-pcl-class class)
 178           (find-structure-class (cl:class-name class)))
 179       class))
 180
 181 (defmethod make-instance ((class cl:class) &rest stuff)
 182   (apply #'make-instance (coerce-to-pcl-class class) stuff))
 183 (defmethod change-class (instance (class cl:class))
 184   (apply #'change-class instance (coerce-to-pcl-class class)))
 185
 186 (macrolet ((frob (&rest names)
 187              `(progn
 188                 ,@(mapcar #'(lambda (name)
 189                               `(defmethod ,name ((class cl:class))
 190                                  (funcall #',name
 191                                           (coerce-to-pcl-class class))))
 192                           names))))
 193   (frob
 194     class-direct-slots
 195     class-prototype
 196     class-precedence-list
 197     class-direct-default-initargs
 198     class-direct-superclasses
 199     compute-class-precedence-list
 200     class-default-initargs class-finalized-p
 201     class-direct-subclasses class-slots
 202     make-instances-obsolete))