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;;; 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 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 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 (specializer lambda-list fmf source-loc) 164 across (remove-if (lambda (x) (member x except)) 165 (cdr (assoc gf-name *!trivial-methods*)) 166 :key #'car) 167 do (multiple-value-bind (specializers arg-info) 168 (ecase gf-name 169 (print-object 170 (values (list (find-class specializer) (find-class t)) 171 '(:arg-info (2)))) 172 (make-load-form 173 (values (list (find-class specializer)) 174 '(:arg-info (1 . t))))) 175 (load-defmethod 176 'standard-method gf-name '() specializers lambda-list 177 `(:function 178 ,(let ((mf (%make-method-function fmf nil))) 179 (sb-mop:set-funcallable-instance-function 180 mf (method-function-from-fast-function fmf arg-info)) 181 mf) 182 plist ,arg-info simple-next-method-call t) 183 source-loc)))) 184(!incorporate-cross-compiled-methods 'make-load-form :except '(layout)) 185 186(defmethod make-load-form ((class class) &optional env) 187 ;; FIXME: should we not instead pass ENV to FIND-CLASS? Probably 188 ;; doesn't matter while all our environments are the same... 189 (declare (ignore env)) 190 (let ((name (class-name class))) 191 (if (and name (eq (find-class name nil) class)) 192 `(find-class ',name) 193 (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>" 194 class)))) 195 196(defmethod make-load-form ((object layout) &optional env) 197 (declare (ignore env)) 198 (if (layout-for-std-class-p object) 199 (let ((pname (classoid-proper-name (layout-classoid object)))) 200 (unless pname 201 (error "can't dump wrapper for anonymous class:~% ~S" 202 (layout-classoid object))) 203 `(classoid-layout (find-classoid ',pname))) 204 :ignore-it)) 205 206;; FIXME: this seems wrong. NO-APPLICABLE-METHOD should be signaled. 207(defun dont-know-how-to-dump (object) 208 (error "~@<don't know how to dump ~S (default ~S method called).~>" 209 object 'make-load-form)) 210 211(macrolet ((define-default-make-load-form-method (class) 212 `(defmethod make-load-form ((object ,class) &optional env) 213 (declare (ignore env)) 214 (dont-know-how-to-dump object)))) 215 (define-default-make-load-form-method structure-object) 216 (define-default-make-load-form-method standard-object) 217 (define-default-make-load-form-method condition)) 218 219sb-impl:: 220(defmethod make-load-form ((host (eql *physical-host*)) &optional env) 221 (declare (ignore env)) 222 '*physical-host*) 223