0.6.12.24:
[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 ;;;; MAKE-LOAD-FORM
112
113 ;; Overwrite the old bootstrap non-generic MAKE-LOAD-FORM function with a
114 ;; shiny new generic function.
115 (fmakunbound 'make-load-form)
116 (defgeneric make-load-form (object &optional environment))
117
118 ;; Link bootstrap-time how-to-dump-it information into the shiny new
119 ;; CLOS system.
120 (defmethod make-load-form ((obj sb-sys:structure!object)
121                            &optional (env nil env-p))
122   (if env-p
123       (sb-sys:structure!object-make-load-form obj env)
124       (sb-sys:structure!object-make-load-form obj)))
125
126 (defmethod make-load-form ((object wrapper) &optional env)
127   (declare (ignore env))
128   (let ((pname (sb-kernel:class-proper-name (sb-kernel:layout-class object))))
129     (unless pname
130       (error "can't dump wrapper for anonymous class:~%  ~S"
131              (sb-kernel:layout-class object)))
132     `(sb-kernel:class-layout (cl:find-class ',pname))))
133 \f
134 ;;;; The following are hacks to deal with CMU CL having two different CLASS
135 ;;;; classes.
136
137 (defun coerce-to-pcl-class (class)
138   (if (typep class 'cl:class)
139       (or (sb-kernel:class-pcl-class class)
140           (find-structure-class (cl:class-name class)))
141       class))
142
143 (defmethod make-instance ((class cl:class) &rest stuff)
144   (apply #'make-instance (coerce-to-pcl-class class) stuff))
145 (defmethod change-class (instance (class cl:class))
146   (apply #'change-class instance (coerce-to-pcl-class class)))
147
148 (macrolet ((frob (&rest names)
149              `(progn
150                 ,@(mapcar #'(lambda (name)
151                               `(defmethod ,name ((class cl:class))
152                                  (funcall #',name
153                                           (coerce-to-pcl-class class))))
154                           names))))
155   (frob
156     class-direct-slots
157     class-prototype
158     class-precedence-list
159     class-direct-default-initargs
160     class-direct-superclasses
161     compute-class-precedence-list
162     class-default-initargs class-finalized-p
163     class-direct-subclasses class-slots
164     make-instances-obsolete))