0.9.5.58:
[sbcl.git] / 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 ;;; TRACE-METHOD and UNTRACE-METHOD accept method specs as arguments. A
35 ;;; method-spec should be a list like:
36 ;;;   (<generic-function-spec> qualifiers* (specializers*))
37 ;;; where <generic-function-spec> should be either a symbol or a list
38 ;;; of (SETF <symbol>).
39 ;;;
40 ;;;   For example, to trace the method defined by:
41 ;;;
42 ;;;     (defmethod foo ((x spaceship)) 'ss)
43 ;;;
44 ;;;   You should say:
45 ;;;
46 ;;;     (trace-method '(foo (spaceship)))
47 ;;;
48 ;;;   You can also provide a method object in the place of the method
49 ;;;   spec, in which case that method object will be traced.
50 ;;;
51 ;;; For UNTRACE-METHOD, if an argument is given, that method is untraced.
52 ;;; If no argument is given, all traced methods are untraced.
53 (defclass traced-method (method)
54      ((method :initarg :method)
55       (function :initarg :function
56                 :reader method-function)
57       (generic-function :initform nil
58                         :accessor method-generic-function)))
59
60 (defmethod method-lambda-list ((m traced-method))
61   (with-slots (method) m (method-lambda-list method)))
62
63 (defmethod method-specializers ((m traced-method))
64   (with-slots (method) m (method-specializers method)))
65
66 (defmethod method-qualifiers ((m traced-method))
67   (with-slots (method) m (method-qualifiers method)))
68
69 (defmethod accessor-method-slot-name ((m traced-method))
70   (with-slots (method) m (accessor-method-slot-name method)))
71
72 (defvar *traced-methods* ())
73
74 (defun trace-method (spec &rest options)
75   (multiple-value-bind (gf omethod name)
76       (parse-method-or-spec spec)
77     (let* ((tfunction (trace-method-internal (method-function omethod)
78                                              name
79                                              options))
80            (tmethod (make-instance 'traced-method
81                                    :method omethod
82                                    :function tfunction)))
83       (remove-method gf omethod)
84       (add-method gf tmethod)
85       (pushnew tmethod *traced-methods*)
86       tmethod)))
87
88 (defun untrace-method (&optional spec)
89   (flet ((untrace-1 (m)
90            (let ((gf (method-generic-function m)))
91              (when gf
92                (remove-method gf m)
93                (add-method gf (slot-value m 'method))
94                (setq *traced-methods* (remove m *traced-methods*))))))
95     (if (not (null spec))
96         (multiple-value-bind (gf method)
97             (parse-method-or-spec spec)
98           (declare (ignore gf))
99           (if (memq method *traced-methods*)
100               (untrace-1 method)
101               (error "~S is not a traced method?" method)))
102         (dolist (m *traced-methods*) (untrace-1 m)))))
103
104 (defun trace-method-internal (ofunction name options)
105   (eval `(untrace ,name))
106   (setf (fdefinition name) ofunction)
107   (eval `(trace ,name ,@options))
108   (fdefinition name))
109 |#
110 \f
111 ;;;; Helper for slightly newer trace implementation, based on
112 ;;;; breakpoint stuff.  The above is potentially still useful, so it's
113 ;;;; left in, commented.
114 (defun list-all-maybe-method-names (gf)
115   (let (result)
116     (dolist (method (generic-function-methods gf) (nreverse result))
117       (let ((spec (nth-value 2 (parse-method-or-spec method))))
118         (push spec result)
119         (push (list* 'fast-method (cdr spec)) result)))))
120 \f
121 ;;;; MAKE-LOAD-FORM
122
123 ;; Overwrite the old bootstrap non-generic MAKE-LOAD-FORM function with a
124 ;; shiny new generic function.
125 (fmakunbound 'make-load-form)
126 (defgeneric make-load-form (object &optional environment))
127
128 ;; Link bootstrap-time how-to-dump-it information into the shiny new
129 ;; CLOS system.
130 (defmethod make-load-form ((obj sb-sys:structure!object)
131                            &optional (env nil env-p))
132   (if env-p
133       (sb-sys:structure!object-make-load-form obj env)
134       (sb-sys:structure!object-make-load-form obj)))
135
136 (defmethod make-load-form ((object wrapper) &optional env)
137   (declare (ignore env))
138   (let ((pname (classoid-proper-name
139                 (layout-classoid object))))
140     (unless pname
141       (error "can't dump wrapper for anonymous class:~%  ~S"
142              (layout-classoid object)))
143     `(classoid-layout (find-classoid ',pname))))
144
145 (defmethod make-load-form ((object structure-object) &optional env)
146   (declare (ignore env))
147   (error "~@<don't know how to dump ~S (default ~S method called).~@>"
148          object 'make-load-form))
149
150 (defmethod make-load-form ((object standard-object) &optional env)
151   (declare (ignore env))
152   (error "~@<don't know how to dump ~S (default ~S method called).~@>"
153          object 'make-load-form))
154
155 (defmethod make-load-form ((object condition) &optional env)
156   (declare (ignore env))
157   (error "~@<don't know how to dump ~S (default ~S method called).~@>"
158          object 'make-load-form))
159
160 (defun make-load-form-saving-slots (object &key slot-names environment)
161   (declare (ignore environment))
162   (let ((class (class-of object)))
163     (collect ((inits))
164       (dolist (slot (class-slots class))
165         (let ((slot-name (slot-definition-name slot)))
166           (when (or (memq slot-name slot-names)
167                     (and (null slot-names)
168                          (eq :instance (slot-definition-allocation slot))))
169             (if (slot-boundp-using-class class object slot)
170                 (let ((value (slot-value-using-class class object slot)))
171                   (if (typep object 'structure-object)
172                       ;; low-level but less noisy initializer form
173                       (let* ((dd (get-structure-dd (class-name class)))
174                              (dsd (find slot-name (dd-slots dd)
175                                         :key #'dsd-name)))
176                         (inits `(,(slot-setter-lambda-form dd dsd)
177                                  ',value ,object)))
178                       (inits `(setf (slot-value ,object ',slot-name) ',value))))
179                 (inits `(slot-makunbound ,object ',slot-name))))))
180       (values `(allocate-instance (find-class ',(class-name class)))
181               `(progn ,@(inits))))))