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         (let ((gf-spec (car spec)))
  47           (multiple-value-bind (quals specls)
  48               (parse-defmethod (cdr spec))
  49             (and (setq gf (and (or errorp (fboundp gf-spec))
  50                                (gdefinition gf-spec)))
  51                  (let ((nreq (compute-discriminating-function-arglist-info gf)))
  52                    (setq specls (append (parse-specializers specls)
  53                                         (make-list (- nreq (length specls))
  54                                                    :initial-element
  55                                                    *the-class-t*)))
  56                    (and
  57                     (setq method (get-method gf quals specls errorp))
  58                     (setq name
  59                           (make-method-spec
  60                            gf-spec quals (unparse-specializers specls)))))))))
  61     (values gf method name)))
  62
  63 ;;; TRACE-METHOD and UNTRACE-METHOD accept method specs as arguments. A
  64 ;;; method-spec should be a list like:
  65 ;;;   (<generic-function-spec> qualifiers* (specializers*))
  66 ;;; where <generic-function-spec> should be either a symbol or a list
  67 ;;; of (SETF <symbol>).
  68 ;;;
  69 ;;;   For example, to trace the method defined by:
  70 ;;;
  71 ;;;     (defmethod foo ((x spaceship)) 'ss)
  72 ;;;
  73 ;;;   You should say:
  74 ;;;
  75 ;;;     (trace-method '(foo (spaceship)))
  76 ;;;
  77 ;;;   You can also provide a method object in the place of the method
  78 ;;;   spec, in which case that method object will be traced.
  79 ;;;
  80 ;;; For UNTRACE-METHOD, if an argument is given, that method is untraced.
  81 ;;; If no argument is given, all traced methods are untraced.
  82 (defclass traced-method (method)
  83      ((method :initarg :method)
  84       (function :initarg :function
  85                 :reader method-function)
  86       (generic-function :initform nil
  87                         :accessor method-generic-function)))
  88
  89 (defmethod method-lambda-list ((m traced-method))
  90   (with-slots (method) m (method-lambda-list method)))
  91
  92 (defmethod method-specializers ((m traced-method))
  93   (with-slots (method) m (method-specializers method)))
  94
  95 (defmethod method-qualifiers ((m traced-method))
  96   (with-slots (method) m (method-qualifiers method)))
  97
  98 (defmethod accessor-method-slot-name ((m traced-method))
  99   (with-slots (method) m (accessor-method-slot-name method)))
 100
 101 (defvar *traced-methods* ())
 102
 103 (defun trace-method (spec &rest options)
 104   (multiple-value-bind (gf omethod name)
 105       (parse-method-or-spec spec)
 106     (let* ((tfunction (trace-method-internal (method-function omethod)
 107                                              name
 108                                              options))
 109            (tmethod (make-instance 'traced-method
 110                                    :method omethod
 111                                    :function tfunction)))
 112       (remove-method gf omethod)
 113       (add-method gf tmethod)
 114       (pushnew tmethod *traced-methods*)
 115       tmethod)))
 116
 117 (defun untrace-method (&optional spec)
 118   (flet ((untrace-1 (m)
 119            (let ((gf (method-generic-function m)))
 120              (when gf
 121                (remove-method gf m)
 122                (add-method gf (slot-value m 'method))
 123                (setq *traced-methods* (remove m *traced-methods*))))))
 124     (if (not (null spec))
 125         (multiple-value-bind (gf method)
 126             (parse-method-or-spec spec)
 127           (declare (ignore gf))
 128           (if (memq method *traced-methods*)
 129               (untrace-1 method)
 130               (error "~S is not a traced method?" method)))
 131         (dolist (m *traced-methods*) (untrace-1 m)))))
 132
 133 (defun trace-method-internal (ofunction name options)
 134   (eval `(untrace ,name))
 135   (setf (fdefinition name) ofunction)
 136   (eval `(trace ,name ,@options))
 137   (fdefinition name))
 138 |#
 139 \f
 140 #|
 141 ;;;; Helper for slightly newer trace implementation, based on
 142 ;;;; breakpoint stuff.  The above is potentially still useful, so it's
 143 ;;;; left in, commented.
 144
 145 ;;; (this turned out to be a roundabout way of doing things)
 146 (defun list-all-maybe-method-names (gf)
 147   (let (result)
 148     (dolist (method (generic-function-methods gf) (nreverse result))
 149       (let ((spec (nth-value 2 (parse-method-or-spec method))))
 150         (push spec result)
 151         (push (list* 'fast-method (cdr spec)) result)))))
 152 |#
 153 \f
 154 ;;;; MAKE-LOAD-FORM
 155
 156 ;; Overwrite the old bootstrap non-generic MAKE-LOAD-FORM function with a
 157 ;; shiny new generic function.
 158 (fmakunbound 'make-load-form)
 159 (defgeneric make-load-form (object &optional environment))
 160
 161 (defun !incorporate-cross-compiled-methods (gf-name &key except)
 162   (assert (generic-function-p (fdefinition gf-name)))
 163   (loop for (predicate fmf specializer qualifier lambda-list source-loc)
 164         ;; Reversing installs less-specific methods first,
 165         ;; so that if perchance we crash mid way through the loop,
 166         ;; there is (hopefully) at least some installed method that works.
 167         across (nreverse (remove-if (lambda (x) (member x except))
 168                                     (cdr (assoc gf-name *!trivial-methods*))
 169                                     :key #'third))
 170         do (multiple-value-bind (specializers arg-info)
 171                (ecase gf-name
 172                  (print-object
 173                   (values (list (find-class specializer) (find-class t))
 174                           '(:arg-info (2))))
 175                  (make-load-form
 176                   (values (list (find-class specializer))
 177                           '(:arg-info (1 . t)))))
 178              (load-defmethod
 179               'standard-method gf-name
 180               (if qualifier (list qualifier)) specializers lambda-list
 181               `(:function
 182                 ,(let ((mf (%make-method-function fmf nil)))
 183                    (sb-mop:set-funcallable-instance-function
 184                     mf (method-function-from-fast-function fmf arg-info))
 185                    mf)
 186                 plist ,arg-info simple-next-method-call t)
 187               source-loc))))
 188 (!incorporate-cross-compiled-methods 'make-load-form :except '(layout))
 189
 190 (defmethod make-load-form ((class class) &optional env)
 191   ;; FIXME: should we not instead pass ENV to FIND-CLASS?  Probably
 192   ;; doesn't matter while all our environments are the same...
 193   (declare (ignore env))
 194   (let ((name (class-name class)))
 195     (if (and name (eq (find-class name nil) class))
 196         `(find-class ',name)
 197         (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
 198                class))))
 199
 200 (defmethod make-load-form ((object layout) &optional env)
 201   (declare (ignore env))
 202   (if (layout-for-std-class-p object)
 203       (let ((pname (classoid-proper-name (layout-classoid object))))
 204         (unless pname
 205           (error "can't dump wrapper for anonymous class:~%  ~S"
 206                  (layout-classoid object)))
 207         `(classoid-layout (find-classoid ',pname)))
 208       :ignore-it))
 209
 210 ;; FIXME: this seems wrong. NO-APPLICABLE-METHOD should be signaled.
 211 (defun dont-know-how-to-dump (object)
 212   (error "~@<don't know how to dump ~S (default ~S method called).~>"
 213          object 'make-load-form))
 214
 215 (macrolet ((define-default-make-load-form-method (class)
 216              `(defmethod make-load-form ((object ,class) &optional env)
 217                 (declare (ignore env))
 218                 (dont-know-how-to-dump object))))
 219   (define-default-make-load-form-method structure-object)
 220   (define-default-make-load-form-method standard-object)
 221   (define-default-make-load-form-method condition))
 222
 223 sb-impl::
 224 (defmethod make-load-form ((host (eql *physical-host*)) &optional env)
 225   (declare (ignore env))
 226   '*physical-host*)