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 \f
  28 ;;; FIXME: This stuff isn't part of the ANSI spec, and isn't even
  29 ;;; exported from PCL, but it looks as though it might be useful,
  30 ;;; so I don't want to just delete it. Perhaps it should go in
  31 ;;; a "contrib" directory eventually?
  32
  33 #|
  34 (defun parse-method-or-spec (spec &optional (errorp t))
  35   (let (gf method name temp)
  36     (if (method-p spec)
  37         (setq method spec
  38               gf (method-generic-function method)
  39               temp (and gf (generic-function-name gf))
  40               name (if temp
  41                        (make-method-spec temp
  42                                          (method-qualifiers method)
  43                                          (unparse-specializers
  44                                           (method-specializers method)))
  45                        (make-symbol (format nil "~S" method))))
  46         (multiple-value-bind (gf-spec quals specls)
  47             (parse-defmethod spec)
  48           (and (setq gf (and (or errorp (fboundp gf-spec))
  49                              (gdefinition gf-spec)))
  50                (let ((nreq (compute-discriminating-function-arglist-info gf)))
  51                  (setq specls (append (parse-specializers specls)
  52                                       (make-list (- nreq (length specls))
  53                                                  :initial-element
  54                                                  *the-class-t*)))
  55                  (and
  56                    (setq method (get-method gf quals specls errorp))
  57                    (setq name
  58                          (make-method-spec
  59                           gf-spec quals (unparse-specializers specls))))))))
  60     (values gf method name)))
  61
  62 ;;; TRACE-METHOD and UNTRACE-METHOD accept method specs as arguments. A
  63 ;;; method-spec should be a list like:
  64 ;;;   (<generic-function-spec> qualifiers* (specializers*))
  65 ;;; where <generic-function-spec> should be either a symbol or a list
  66 ;;; of (SETF <symbol>).
  67 ;;;
  68 ;;;   For example, to trace the method defined by:
  69 ;;;
  70 ;;;     (defmethod foo ((x spaceship)) 'ss)
  71 ;;;
  72 ;;;   You should say:
  73 ;;;
  74 ;;;     (trace-method '(foo (spaceship)))
  75 ;;;
  76 ;;;   You can also provide a method object in the place of the method
  77 ;;;   spec, in which case that method object will be traced.
  78 ;;;
  79 ;;; For UNTRACE-METHOD, if an argument is given, that method is untraced.
  80 ;;; If no argument is given, all traced methods are untraced.
  81 (defclass traced-method (method)
  82      ((method :initarg :method)
  83       (function :initarg :function
  84                 :reader method-function)
  85       (generic-function :initform nil
  86                         :accessor method-generic-function)))
  87
  88 (defmethod method-lambda-list ((m traced-method))
  89   (with-slots (method) m (method-lambda-list method)))
  90
  91 (defmethod method-specializers ((m traced-method))
  92   (with-slots (method) m (method-specializers method)))
  93
  94 (defmethod method-qualifiers ((m traced-method))
  95   (with-slots (method) m (method-qualifiers method)))
  96
  97 (defmethod accessor-method-slot-name ((m traced-method))
  98   (with-slots (method) m (accessor-method-slot-name method)))
  99
 100 (defvar *traced-methods* ())
 101
 102 (defun trace-method (spec &rest options)
 103   (multiple-value-bind (gf omethod name)
 104       (parse-method-or-spec spec)
 105     (let* ((tfunction (trace-method-internal (method-function omethod)
 106                                              name
 107                                              options))
 108            (tmethod (make-instance 'traced-method
 109                                    :method omethod
 110                                    :function tfunction)))
 111       (remove-method gf omethod)
 112       (add-method gf tmethod)
 113       (pushnew tmethod *traced-methods*)
 114       tmethod)))
 115
 116 (defun untrace-method (&optional spec)
 117   (flet ((untrace-1 (m)
 118            (let ((gf (method-generic-function m)))
 119              (when gf
 120                (remove-method gf m)
 121                (add-method gf (slot-value m 'method))
 122                (setq *traced-methods* (remove m *traced-methods*))))))
 123     (if (not (null spec))
 124         (multiple-value-bind (gf method)
 125             (parse-method-or-spec spec)
 126           (declare (ignore gf))
 127           (if (memq method *traced-methods*)
 128               (untrace-1 method)
 129               (error "~S is not a traced method?" method)))
 130         (dolist (m *traced-methods*) (untrace-1 m)))))
 131
 132 (defun trace-method-internal (ofunction name options)
 133   (eval `(untrace ,name))
 134   (setf (fdefinition name) ofunction)
 135   (eval `(trace ,name ,@options))
 136   (fdefinition name))
 137 |#
 138 \f
 139 #|
 140 ;;;; Helper for slightly newer trace implementation, based on
 141 ;;;; breakpoint stuff.  The above is potentially still useful, so it's
 142 ;;;; left in, commented.
 143
 144 ;;; (this turned out to be a roundabout way of doing things)
 145 (defun list-all-maybe-method-names (gf)
 146   (let (result)
 147     (dolist (method (generic-function-methods gf) (nreverse result))
 148       (let ((spec (nth-value 2 (parse-method-or-spec method))))
 149         (push spec result)
 150         (push (list* 'fast-method (cdr spec)) result)))))
 151 |#
 152 \f
 153 ;;;; MAKE-LOAD-FORM
 154
 155 ;; Overwrite the old bootstrap non-generic MAKE-LOAD-FORM function with a
 156 ;; shiny new generic function.
 157 (fmakunbound 'make-load-form)
 158 (defgeneric make-load-form (object &optional environment))
 159
 160 ;; Link bootstrap-time how-to-dump-it information into the shiny new
 161 ;; CLOS system.
 162 (defmethod make-load-form ((obj sb-sys:structure!object)
 163                            &optional (env nil env-p))
 164   (if env-p
 165       (sb-sys:structure!object-make-load-form obj env)
 166       (sb-sys:structure!object-make-load-form obj)))
 167
 168 (defmethod make-load-form ((object wrapper) &optional env)
 169   (declare (ignore env))
 170   (let ((pname (classoid-proper-name
 171                 (layout-classoid object))))
 172     (unless pname
 173       (error "can't dump wrapper for anonymous class:~%  ~S"
 174              (layout-classoid object)))
 175     `(classoid-layout (find-classoid ',pname))))
 176
 177 (defmethod make-load-form ((object structure-object) &optional env)
 178   (declare (ignore env))
 179   (error "~@<don't know how to dump ~S (default ~S method called).~@>"
 180          object 'make-load-form))
 181
 182 (defmethod make-load-form ((object standard-object) &optional env)
 183   (declare (ignore env))
 184   (error "~@<don't know how to dump ~S (default ~S method called).~@>"
 185          object 'make-load-form))
 186
 187 (defmethod make-load-form ((object condition) &optional env)
 188   (declare (ignore env))
 189   (error "~@<don't know how to dump ~S (default ~S method called).~@>"
 190          object 'make-load-form))
 191
 192 (defun make-load-form-saving-slots (object &key (slot-names nil slot-names-p) environment)
 193   (declare (ignore environment))
 194   (let ((class (class-of object)))
 195     (collect ((inits))
 196       (dolist (slot (class-slots class))
 197         (let ((slot-name (slot-definition-name slot)))
 198           (when (or (memq slot-name slot-names)
 199                     (and (not slot-names-p)
 200                          (eq :instance (slot-definition-allocation slot))))
 201             (if (slot-boundp-using-class class object slot)
 202                 (let ((value (slot-value-using-class class object slot)))
 203                   (if (typep object 'structure-object)
 204                       ;; low-level but less noisy initializer form
 205                       ;; FIXME: why not go class->layout->info == dd?
 206                       (let* ((dd (find-defstruct-description
 207                                   (class-name class)))
 208                              (dsd (find slot-name (dd-slots dd)
 209                                         :key #'dsd-name)))
 210                         (inits `(,(slot-setter-lambda-form dd dsd)
 211                                  ',value ,object)))
 212                       (inits `(setf (slot-value ,object ',slot-name) ',value))))
 213                 (inits `(slot-makunbound ,object ',slot-name))))))
 214       (values `(allocate-instance (find-class ',(class-name class)))
 215               `(progn ,@(inits))))))