1 ;;;; basic environmental stuff
3 ;;;; This software is part of the SBCL system. See the README file for
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
12 ;;;; copyright information from original PCL sources:
14 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
15 ;;;; All rights reserved.
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
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
31 ;;; FIXME: This stuff isn't part of the ANSI spec, and isn't even
32 ;;; exported from PCL, but it looks as though it might be useful,
33 ;;; so I don't want to just delete it. Perhaps it should go in
34 ;;; a contrib/ directory eventually?
37 ;;; TRACE-METHOD and UNTRACE-METHOD accept method specs as arguments. A
38 ;;; method-spec should be a list like:
39 ;;; (<generic-function-spec> qualifiers* (specializers*))
40 ;;; where <generic-function-spec> should be either a symbol or a list
41 ;;; of (SETF <symbol>).
43 ;;; For example, to trace the method defined by:
45 ;;; (defmethod foo ((x spaceship)) 'ss)
49 ;;; (trace-method '(foo (spaceship)))
51 ;;; You can also provide a method object in the place of the method
52 ;;; spec, in which case that method object will be traced.
54 ;;; For untrace-method, if an argument is given, that method is untraced.
55 ;;; If no argument is given, all traced methods are untraced.
56 (defclass traced-method (method)
57 ((method :initarg :method)
58 (function :initarg :function
59 :reader method-function)
60 (generic-function :initform nil
61 :accessor method-generic-function)))
63 (defmethod method-lambda-list ((m traced-method))
64 (with-slots (method) m (method-lambda-list method)))
66 (defmethod method-specializers ((m traced-method))
67 (with-slots (method) m (method-specializers method)))
69 (defmethod method-qualifiers ((m traced-method))
70 (with-slots (method) m (method-qualifiers method)))
72 (defmethod accessor-method-slot-name ((m traced-method))
73 (with-slots (method) m (accessor-method-slot-name method)))
75 (defvar *traced-methods* ())
77 (defun trace-method (spec &rest options)
78 (multiple-value-bind (gf omethod name)
79 (parse-method-or-spec spec)
80 (let* ((tfunction (trace-method-internal (method-function omethod)
83 (tmethod (make-instance 'traced-method
85 :function tfunction)))
86 (remove-method gf omethod)
87 (add-method gf tmethod)
88 (pushnew tmethod *traced-methods*)
91 (defun untrace-method (&optional spec)
93 (let ((gf (method-generic-function m)))
96 (add-method gf (slot-value m 'method))
97 (setq *traced-methods* (remove m *traced-methods*))))))
99 (multiple-value-bind (gf method)
100 (parse-method-or-spec spec)
101 (declare (ignore gf))
102 (if (memq method *traced-methods*)
104 (error "~S is not a traced method?" method)))
105 (dolist (m *traced-methods*) (untrace-1 m)))))
107 (defun trace-method-internal (ofunction name options)
108 (eval `(untrace ,name))
109 (setf (symbol-function name) ofunction)
110 (eval `(trace ,name ,@options))
111 (symbol-function name))
114 ;(defun compile-method (spec)
115 ; (multiple-value-bind (gf method name)
116 ; (parse-method-or-spec spec)
117 ; (declare (ignore gf))
118 ; (compile name (method-function method))
119 ; (setf (method-function method) (symbol-function name))))
123 (defmacro undefmethod (&rest args)
124 (declare (arglist name {method-qualifier}* specializers))
125 `(undefmethod-1 ',args))
127 (defun undefmethod-1 (args)
128 (multiple-value-bind (gf method)
129 (parse-method-or-spec args)
130 (when (and gf method)
131 (remove-method gf method)
135 ;;; FIXME: Delete these.
137 (pushnew :pcl *features*)
138 (pushnew :portable-commonloops *features*)
139 (pushnew :pcl-structures *features*)
142 ;;; FIXME: This was for some unclean bootstrapping thing we don't
143 ;;; need in SBCL, right? So we can delete it, right?
145 ;;; (when (find-package "OLD-PCL")
146 ;;; (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl))
147 ;;; (symbol-function 'sb-pcl::print-object)))
151 ;; Overwrite the old bootstrap non-generic MAKE-LOAD-FORM function with a
152 ;; shiny new generic function.
153 (fmakunbound 'make-load-form)
154 (defgeneric make-load-form (object &optional environment))
156 ;; Link bootstrap-time how-to-dump-it information into the shiny new
158 (defmethod make-load-form ((obj sb-sys:structure!object)
159 &optional (env nil env-p))
161 (sb-sys:structure!object-make-load-form obj env)
162 (sb-sys:structure!object-make-load-form obj)))
164 (defmethod make-load-form ((object wrapper) &optional env)
165 (declare (ignore env))
166 (let ((pname (sb-kernel:class-proper-name (sb-kernel:layout-class object))))
168 (error "can't dump wrapper for anonymous class:~% ~S"
169 (sb-kernel:layout-class object)))
170 `(sb-kernel:class-layout (cl:find-class ',pname))))
172 ;;;; The following are hacks to deal with CMU CL having two different CLASS
175 (defun coerce-to-pcl-class (class)
176 (if (typep class 'cl:class)
177 (or (sb-kernel:class-pcl-class class)
178 (find-structure-class (cl:class-name class)))
181 (defmethod make-instance ((class cl:class) &rest stuff)
182 (apply #'make-instance (coerce-to-pcl-class class) stuff))
183 (defmethod change-class (instance (class cl:class))
184 (apply #'change-class instance (coerce-to-pcl-class class)))
186 (macrolet ((frob (&rest names)
188 ,@(mapcar #'(lambda (name)
189 `(defmethod ,name ((class cl:class))
191 (coerce-to-pcl-class class))))
196 class-precedence-list
197 class-direct-default-initargs
198 class-direct-superclasses
199 compute-class-precedence-list
200 class-default-initargs class-finalized-p
201 class-direct-subclasses class-slots
202 make-instances-obsolete))