Fix make-array transforms.
[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 (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 ;; Link bootstrap-time how-to-dump-it information into the shiny new
162 ;; CLOS system.
163 (defmethod make-load-form ((obj sb-sys:structure!object)
164                            &optional (env nil env-p))
165   (if env-p
166       (sb-sys:structure!object-make-load-form obj env)
167       (sb-sys:structure!object-make-load-form obj)))
168
169 (defmethod make-load-form ((object wrapper) &optional env)
170   (declare (ignore env))
171   (let ((pname (classoid-proper-name
172                 (layout-classoid object))))
173     (unless pname
174       (error "can't dump wrapper for anonymous class:~%  ~S"
175              (layout-classoid object)))
176     `(classoid-layout (find-classoid ',pname))))
177
178 (defmethod make-load-form ((object structure-object) &optional env)
179   (declare (ignore env))
180   (error "~@<don't know how to dump ~S (default ~S method called).~>"
181          object 'make-load-form))
182
183 (defmethod make-load-form ((object standard-object) &optional env)
184   (declare (ignore env))
185   (error "~@<don't know how to dump ~S (default ~S method called).~>"
186          object 'make-load-form))
187
188 (defmethod make-load-form ((object condition) &optional env)
189   (declare (ignore env))
190   (error "~@<don't know how to dump ~S (default ~S method called).~>"
191          object 'make-load-form))
192
193 (defun make-load-form-saving-slots (object &key (slot-names nil slot-names-p) environment)
194   (declare (ignore environment))
195   (let ((class (class-of object)))
196     (collect ((inits))
197       (dolist (slot (class-slots class))
198         (let ((slot-name (slot-definition-name slot)))
199           (when (or (memq slot-name slot-names)
200                     (and (not slot-names-p)
201                          (eq :instance (slot-definition-allocation slot))))
202             (if (slot-boundp-using-class class object slot)
203                 (let ((value (slot-value-using-class class object slot)))
204                   (if (typep object 'structure-object)
205                       ;; low-level but less noisy initializer form
206                       ;; FIXME: why not go class->layout->info == dd?
207                       (let* ((dd (find-defstruct-description
208                                   (class-name class)))
209                              (dsd (find slot-name (dd-slots dd)
210                                         :key #'dsd-name)))
211                         (inits `(,(slot-setter-lambda-form dd dsd)
212                                  ',value ,object)))
213                       (inits `(setf (slot-value ,object ',slot-name) ',value))))
214                 (inits `(slot-makunbound ,object ',slot-name))))))
215       (values `(allocate-instance (find-class ',(class-name class)))
216               `(progn ,@(inits))))))