X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fenv.lisp;h=f1cf98f59fa45a2614806a82e117c4013ae46803;hb=990728854b8ba017888811d1b0453b15dfa8a581;hp=b63eaaab2f93875debdedc711f145d2f260724d1;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git

diff --git a/src/pcl/env.lisp b/src/pcl/env.lisp
index b63eaaa..f1cf98f 100644
--- a/src/pcl/env.lisp
+++ b/src/pcl/env.lisp
@@ -24,16 +24,41 @@
 ;;;; specification.
 
 (in-package "SB-PCL")
-
-(sb-int:file-comment
-  "$Header$")
 
 ;;; 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?
 
 #|
+(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))))
+        (multiple-value-bind (gf-spec quals specls)
+            (parse-defmethod 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*))
@@ -51,14 +76,14 @@
 ;;;   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)
       (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)))
@@ -78,11 +103,11 @@
   (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*)
@@ -90,61 +115,40 @@
 
 (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))
-  (setf (symbol-function name) ofunction)
+  (setf (fdefinition name) ofunction)
   (eval `(trace ,name ,@options))
-  (symbol-function name))
+  (fdefinition name))
 |#
 
-;(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)))
+;;;; 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)))))
 |#
-
-;;; 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)))
 
 ;;;; MAKE-LOAD-FORM
 
@@ -156,47 +160,56 @@
 ;; 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))))
-
-;;;; 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 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))))))