X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fenv.lisp;h=fadcb9366678cc2be153dd0c56751ee82cc30827;hb=77d1a39f28fe8d240cf441a9a54a80d4bc98ea52;hp=e8a0e06246685dd014272ad6d18499d00d73a7f9;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/pcl/env.lisp b/src/pcl/env.lisp index e8a0e06..fadcb93 100644 --- a/src/pcl/env.lisp +++ b/src/pcl/env.lisp @@ -28,7 +28,7 @@ ;;; 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 @@ -48,7 +48,7 @@ ;;; 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) @@ -103,45 +103,20 @@ (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))) -|# - -;;; 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))) +;;;; Helper for slightly newer trace implementation, based on +;;;; breakpoint stuff. The above is potentially still useful, so it's +;;;; left in, commented. +(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))))) ;;;; MAKE-LOAD-FORM @@ -160,40 +135,47 @@ (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 "~@" + object 'make-load-form)) + +(defmethod make-load-form ((object standard-object) &optional env) + (declare (ignore env)) + (error "~@" + object 'make-load-form)) + +(defmethod make-load-form ((object condition) &optional env) + (declare (ignore env)) + (error "~@" + 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))))))