;;;; specification.
(in-package "SB-PCL")
-
-(sb-int:file-comment
- "$Header$")
\f
;;; FIXME: This stuff isn't part of the ANSI spec, and isn't even
;;; exported from PCL, but it looks as though it might be useful,
;;; so I don't want to just delete it. Perhaps it should go in
-;;; a contrib/ directory eventually?
+;;; a "contrib" directory eventually?
#|
;;; TRACE-METHOD and UNTRACE-METHOD accept method specs as arguments. A
;;; You can also provide a method object in the place of the method
;;; spec, in which case that method object will be traced.
;;;
-;;; For untrace-method, if an argument is given, that method is untraced.
+;;; For UNTRACE-METHOD, if an argument is given, that method is untraced.
;;; If no argument is given, all traced methods are untraced.
(defclass traced-method (method)
((method :initarg :method)
(defun trace-method-internal (ofunction name options)
(eval `(untrace ,name))
- (setf (symbol-function name) ofunction)
+ (setf (fdefinition name) ofunction)
(eval `(trace ,name ,@options))
- (symbol-function name))
-|#
-\f
-;(defun compile-method (spec)
-; (multiple-value-bind (gf method name)
-; (parse-method-or-spec spec)
-; (declare (ignore gf))
-; (compile name (method-function method))
-; (setf (method-function method) (symbol-function name))))
-
-;;; not used in SBCL
-#|
-(defmacro undefmethod (&rest args)
- (declare (arglist name {method-qualifier}* specializers))
- `(undefmethod-1 ',args))
-
-(defun undefmethod-1 (args)
- (multiple-value-bind (gf method)
- (parse-method-or-spec args)
- (when (and gf method)
- (remove-method gf method)
- method)))
+ (fdefinition name))
|#
-
-;;; FIXME: Delete these.
-#|
-(pushnew :pcl *features*)
-(pushnew :portable-commonloops *features*)
-(pushnew :pcl-structures *features*)
-|#
-
-;;; FIXME: This was for some unclean bootstrapping thing we don't
-;;; need in SBCL, right? So we can delete it, right?
-;;; #+cmu
-;;; (when (find-package "OLD-PCL")
-;;; (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl))
-;;; (symbol-function 'sb-pcl::print-object)))
\f
;;;; MAKE-LOAD-FORM
(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))
- (apply #'change-class instance (coerce-to-pcl-class class)))
-
-(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 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 (null slot-names)
+ (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
+ (let* ((dd (get-structure-dd (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