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