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