;;; a "contrib" directory eventually?
#|
+(defun parse-method-or-spec (spec &optional (errorp t))
+ (let (gf method name temp)
+ (if (method-p spec)
+ (setq method spec
+ gf (method-generic-function method)
+ temp (and gf (generic-function-name gf))
+ name (if temp
+ (make-method-spec temp
+ (method-qualifiers method)
+ (unparse-specializers
+ (method-specializers method)))
+ (make-symbol (format nil "~S" method))))
+ (let ((gf-spec (car spec)))
+ (multiple-value-bind (quals specls)
+ (parse-defmethod (cdr spec))
+ (and (setq gf (and (or errorp (fboundp gf-spec))
+ (gdefinition gf-spec)))
+ (let ((nreq (compute-discriminating-function-arglist-info gf)))
+ (setq specls (append (parse-specializers specls)
+ (make-list (- nreq (length specls))
+ :initial-element
+ *the-class-t*)))
+ (and
+ (setq method (get-method gf quals specls errorp))
+ (setq name
+ (make-method-spec
+ gf-spec quals (unparse-specializers specls)))))))))
+ (values gf method name)))
+
;;; TRACE-METHOD and UNTRACE-METHOD accept method specs as arguments. A
;;; method-spec should be a list like:
;;; (<generic-function-spec> qualifiers* (specializers*))
(defclass traced-method (method)
((method :initarg :method)
(function :initarg :function
- :reader method-function)
+ :reader method-function)
(generic-function :initform nil
- :accessor method-generic-function)))
+ :accessor method-generic-function)))
(defmethod method-lambda-list ((m traced-method))
(with-slots (method) m (method-lambda-list method)))
(multiple-value-bind (gf omethod name)
(parse-method-or-spec spec)
(let* ((tfunction (trace-method-internal (method-function omethod)
- name
- options))
- (tmethod (make-instance 'traced-method
- :method omethod
- :function tfunction)))
+ name
+ options))
+ (tmethod (make-instance 'traced-method
+ :method omethod
+ :function tfunction)))
(remove-method gf omethod)
(add-method gf tmethod)
(pushnew tmethod *traced-methods*)
(defun untrace-method (&optional spec)
(flet ((untrace-1 (m)
- (let ((gf (method-generic-function m)))
- (when gf
- (remove-method gf m)
- (add-method gf (slot-value m 'method))
- (setq *traced-methods* (remove m *traced-methods*))))))
+ (let ((gf (method-generic-function m)))
+ (when gf
+ (remove-method gf m)
+ (add-method gf (slot-value m 'method))
+ (setq *traced-methods* (remove m *traced-methods*))))))
(if (not (null spec))
- (multiple-value-bind (gf method)
- (parse-method-or-spec spec)
- (declare (ignore gf))
- (if (memq method *traced-methods*)
- (untrace-1 method)
- (error "~S is not a traced method?" method)))
- (dolist (m *traced-methods*) (untrace-1 m)))))
+ (multiple-value-bind (gf method)
+ (parse-method-or-spec spec)
+ (declare (ignore gf))
+ (if (memq method *traced-methods*)
+ (untrace-1 method)
+ (error "~S is not a traced method?" method)))
+ (dolist (m *traced-methods*) (untrace-1 m)))))
(defun trace-method-internal (ofunction name options)
(eval `(untrace ,name))
(fdefinition name))
|#
\f
+#|
+;;;; Helper for slightly newer trace implementation, based on
+;;;; breakpoint stuff. The above is potentially still useful, so it's
+;;;; left in, commented.
+
+;;; (this turned out to be a roundabout way of doing things)
+(defun list-all-maybe-method-names (gf)
+ (let (result)
+ (dolist (method (generic-function-methods gf) (nreverse result))
+ (let ((spec (nth-value 2 (parse-method-or-spec method))))
+ (push spec result)
+ (push (list* 'fast-method (cdr spec)) result)))))
+|#
+\f
;;;; MAKE-LOAD-FORM
;; Overwrite the old bootstrap non-generic MAKE-LOAD-FORM function with a
;; Link bootstrap-time how-to-dump-it information into the shiny new
;; CLOS system.
(defmethod make-load-form ((obj sb-sys:structure!object)
- &optional (env nil env-p))
+ &optional (env nil env-p))
(if env-p
(sb-sys:structure!object-make-load-form obj env)
(sb-sys:structure!object-make-load-form obj)))
(defmethod make-load-form ((object wrapper) &optional env)
(declare (ignore env))
- (let ((pname (sb-kernel:class-proper-name (sb-kernel:layout-class object))))
+ (let ((pname (classoid-proper-name
+ (layout-classoid object))))
(unless pname
(error "can't dump wrapper for anonymous class:~% ~S"
- (sb-kernel:layout-class object)))
- `(sb-kernel:class-layout (cl:find-class ',pname))))
-\f
-;;;; The following are hacks to deal with CMU CL having two different CLASS
-;;;; classes.
-
-(defun coerce-to-pcl-class (class)
- (if (typep class 'cl:class)
- (or (sb-kernel:class-pcl-class class)
- (find-structure-class (cl:class-name class)))
- class))
-
-(defmethod make-instance ((class cl:class) &rest stuff)
- (apply #'make-instance (coerce-to-pcl-class class) stuff))
-(defmethod change-class (instance (class cl:class) &rest initargs)
- (apply #'change-class instance (coerce-to-pcl-class class) initargs))
-
-(macrolet ((frob (&rest names)
- `(progn
- ,@(mapcar (lambda (name)
- `(defmethod ,name ((class cl:class))
- (funcall #',name
- (coerce-to-pcl-class class))))
- names))))
- (frob
- class-direct-slots
- class-prototype
- class-precedence-list
- class-direct-default-initargs
- class-direct-superclasses
- compute-class-precedence-list
- class-default-initargs class-finalized-p
- class-direct-subclasses class-slots
- make-instances-obsolete))
+ (layout-classoid object)))
+ `(classoid-layout (find-classoid ',pname))))
+
+(defmethod make-load-form ((object structure-object) &optional env)
+ (declare (ignore env))
+ (error "~@<don't know how to dump ~S (default ~S method called).~>"
+ object 'make-load-form))
+
+(defmethod make-load-form ((object standard-object) &optional env)
+ (declare (ignore env))
+ (error "~@<don't know how to dump ~S (default ~S method called).~>"
+ object 'make-load-form))
+
+(defmethod make-load-form ((object condition) &optional env)
+ (declare (ignore env))
+ (error "~@<don't know how to dump ~S (default ~S method called).~>"
+ object 'make-load-form))
+
+(defun make-load-form-saving-slots (object &key (slot-names nil slot-names-p) environment)
+ (declare (ignore environment))
+ (let ((class (class-of object)))
+ (collect ((inits))
+ (dolist (slot (class-slots class))
+ (let ((slot-name (slot-definition-name slot)))
+ (when (or (memq slot-name slot-names)
+ (and (not slot-names-p)
+ (eq :instance (slot-definition-allocation slot))))
+ (if (slot-boundp-using-class class object slot)
+ (let ((value (slot-value-using-class class object slot)))
+ (if (typep object 'structure-object)
+ ;; low-level but less noisy initializer form
+ ;; FIXME: why not go class->layout->info == dd?
+ (let* ((dd (find-defstruct-description
+ (class-name class)))
+ (dsd (find slot-name (dd-slots dd)
+ :key #'dsd-name)))
+ (inits `(,(slot-setter-lambda-form dd dsd)
+ ',value ,object)))
+ (inits `(setf (slot-value ,object ',slot-name) ',value))))
+ (inits `(slot-makunbound ,object ',slot-name))))))
+ (values `(allocate-instance (find-class ',(class-name class)))
+ `(progn ,@(inits))))))
projects / sbcl.git / blobdiff