From: Christophe Rhodes Date: Fri, 2 Dec 2005 22:53:04 +0000 (+0000) Subject: 0.9.7.10: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=310aee0b439b715a5ec242862ab0a4d254e123b5;p=sbcl.git 0.9.7.10: PCL smallification... ... no more (SB-PCL::CLASS-PREDICATE FOO). (Oh, the irony: the case which made me implement generalised function names was completely unused :-) ... deletes one slot, one generic function and two methods per class. ... some minor rearrangements of the braid/bootstrap. This exposes a code path which could never possibly have worked: now that we're not creating a class-predicate, we end up in a different place for creating the cell of a class slot added by a mop user. Fix the embarrassingly wrong code (and yay for automated tests). --- diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 9983c49..3920052 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -288,8 +288,6 @@ (set-slot 'direct-subclasses (classes direct-subclasses)) (set-slot 'direct-methods (cons nil nil)) (set-slot 'wrapper wrapper) - (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*)) - (make-class-predicate-name name))) (set-slot 'documentation nil) (set-slot 'plist `(,@(and direct-default-initargs @@ -320,9 +318,6 @@ (case metaclass-name (structure-class (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|)) - (set-slot 'predicate-name (or (cadr (assoc name - *early-class-predicates*)) - (make-class-predicate-name name))) (set-slot 'defstruct-form `(defstruct (structure-object (:constructor ,constructor-sym) @@ -471,13 +466,13 @@ (dolist (writer writers) (do-writer-definition writer)) (dolist (boundp boundps) (do-boundp-definition boundp)))) +;;; FIXME: find a better name. (defun !bootstrap-class-predicates (early-p) (let ((*early-p* early-p)) - (dolist (definition *early-class-definitions*) - (let* ((name (ecd-class-name definition)) - (class (find-class name))) - (setf (find-class-predicate name) - (make-class-predicate class (class-predicate-name class))))))) + (dolist (ecp *early-class-predicates*) + (let ((class-name (car ecp)) + (predicate-name (cadr ecp))) + (make-class-predicate (find-class class-name) predicate-name))))) (defun !bootstrap-built-in-classes () @@ -516,13 +511,7 @@ name class-eq-wrapper nil supers subs (cons name cpl) - wrapper prototype))))) - - (dolist (e *built-in-classes*) - (let* ((name (car e)) - (class (find-class name))) - (setf (find-class-predicate name) - (make-class-predicate class (class-predicate-name class)))))) + wrapper prototype)))))) (defmacro wrapper-of-macro (x) `(layout-of ,x)) diff --git a/src/pcl/compiler-support.lisp b/src/pcl/compiler-support.lisp index 58e462f..5cc7d3f 100644 --- a/src/pcl/compiler-support.lisp +++ b/src/pcl/compiler-support.lisp @@ -69,13 +69,6 @@ (define-function-name-syntax ,name ,@body) (pushnew ',name sb-pcl::*internal-pcl-generalized-fun-name-symbols*))) -(define-internal-pcl-function-name-syntax sb-pcl::class-predicate (list) - (when (cdr list) - (destructuring-bind (name &rest rest) (cdr list) - (when (and (symbolp name) - (null rest)) - (values t name))))) - (define-internal-pcl-function-name-syntax sb-pcl::slot-accessor (list) (when (= (length list) 4) (destructuring-bind (class slot rwb) (cdr list) diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index 21e886f..c649f24 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -56,15 +56,6 @@ ;;;; method combination object just reads the parameters out of the object ;;;; and runs the same rule. -(defclass short-method-combination (standard-method-combination) - ((operator - :reader short-combination-operator - :initarg :operator) - (identity-with-one-argument - :reader short-combination-identity-with-one-argument - :initarg :identity-with-one-argument)) - (:predicate-name short-method-combination-p)) - (defun expand-short-defcombin (whole) (let* ((type (cadr whole)) (documentation diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index d8ac2ec..8ecbb74 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -204,9 +204,6 @@ (defvar *standard-method-combination*) -(defun make-class-predicate-name (name) - (list 'class-predicate name)) - (defun plist-value (object name) (getf (object-plist object) name)) @@ -436,6 +433,14 @@ :initarg :args-lambda-list :reader long-method-combination-args-lambda-list))) +(defclass short-method-combination (standard-method-combination) + ((operator + :reader short-combination-operator + :initarg :operator) + (identity-with-one-argument + :reader short-combination-identity-with-one-argument + :initarg :identity-with-one-argument))) + (defclass slot-definition (metaobject) ((name :initform nil @@ -598,9 +603,6 @@ :reader class-direct-subclasses) (direct-methods :initform (cons nil nil)) - (predicate-name - :initform nil - :reader class-predicate-name) (documentation :initform nil :initarg :documentation) @@ -710,5 +712,5 @@ (generic-function generic-function-p) (standard-generic-function standard-generic-function-p) (method-combination method-combination-p) - (long-method-combination long-method-combination-p))) - + (long-method-combination long-method-combination-p) + (short-method-combination short-method-combination-p))) diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp index 6db290a..e0dabdf 100644 --- a/src/pcl/generic-functions.lisp +++ b/src/pcl/generic-functions.lisp @@ -76,8 +76,6 @@ (defgeneric class-precedence-list (pcl-class)) -(defgeneric class-predicate-name (class)) - (defgeneric class-wrapper (pcl-class)) (defgeneric definition-source (definition-source-mixin)) diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index 4aa875b..f676758 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -113,11 +113,6 @@ (t (error "~S is not a legal class name." symbol))))) -(defun find-class-predicate-from-cell (symbol cell &optional (errorp t)) - (unless (find-class-cell-class cell) - (find-class-from-cell symbol cell errorp)) - (find-class-cell-predicate cell)) - (defun legal-class-name-p (x) (symbolp x)) @@ -127,11 +122,6 @@ (find-class-cell symbol errorp) errorp)) -(defun find-class-predicate (symbol &optional (errorp t) environment) - (declare (ignore environment)) - (find-class-predicate-from-cell symbol - (find-class-cell symbol errorp) - errorp)) ;;; This DEFVAR was originally in defs.lisp, now moved here. ;;; @@ -174,10 +164,6 @@ (setf (find-classoid name) nil)) (when (or (eq *boot-state* 'complete) (eq *boot-state* 'braid)) - (when (and new-value (class-wrapper new-value) - (class-predicate-name new-value)) - (setf (find-class-cell-predicate cell) - (fdefinition (class-predicate-name new-value)))) (update-ctors 'setf-find-class :class new-value :name name)) new-value)) (t @@ -185,12 +171,6 @@ (/show "pcl/macros.lisp 230") -(defun (setf find-class-predicate) - (new-value symbol) - (if (legal-class-name-p symbol) - (setf (find-class-cell-predicate (find-class-cell symbol)) new-value) - (error "~S is not a legal class name." symbol))) - (defun find-wrapper (symbol) (class-wrapper (find-class symbol))) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index a7533d3..cf2eb6e 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -333,9 +333,6 @@ (set-class-type-translation class name) class)) -(defmethod class-predicate-name ((class t)) - 'constantly-nil) - (defun fix-super (s) (cond ((classp s) s) ((not (legal-class-name-p s)) @@ -367,12 +364,10 @@ (defmethod shared-initialize :after - ((class std-class) - slot-names - &key (direct-superclasses nil direct-superclasses-p) - (direct-slots nil direct-slots-p) - (direct-default-initargs nil direct-default-initargs-p) - (predicate-name nil predicate-name-p)) + ((class std-class) slot-names &key + (direct-superclasses nil direct-superclasses-p) + (direct-slots nil direct-slots-p) + (direct-default-initargs nil direct-default-initargs-p)) (cond (direct-superclasses-p (setq direct-superclasses (or direct-superclasses @@ -419,15 +414,7 @@ (push (cons name value) collect)) (push old collect))))) (nreverse collect))) - (setq predicate-name (if predicate-name-p - (setf (slot-value class 'predicate-name) - (car predicate-name)) - (or (slot-value class 'predicate-name) - (setf (slot-value class 'predicate-name) - (make-class-predicate-name (class-name - class)))))) (add-direct-subclasses class direct-superclasses) - (make-class-predicate class predicate-name) (update-class class nil) (do* ((slots (slot-value class 'slots) (cdr slots)) (dupes nil)) @@ -534,8 +521,7 @@ (declare (ignore slot-names)) (let ((classoid (find-classoid (class-name class)))) (with-slots (wrapper class-precedence-list cpl-available-p - prototype predicate-name - (direct-supers direct-superclasses)) + prototype (direct-supers direct-superclasses)) class (setf (slot-value class 'direct-slots) (mapcar (lambda (pl) (make-direct-slotd class pl)) @@ -547,8 +533,6 @@ (setq class-precedence-list (compute-class-precedence-list class)) (setq cpl-available-p t) (add-direct-subclasses class direct-superclasses) - (setq predicate-name (make-class-predicate-name (class-name class))) - (make-class-predicate class predicate-name) (setf (slot-value class 'slots) (compute-slots class)))) ;; Comment from Gerd's PCL, 2003-05-15: ;; @@ -676,12 +660,10 @@ (sb-kernel::compiler-layout-or-lose (dd-name dd)))))) (defmethod shared-initialize :after - ((class structure-class) - slot-names - &key (direct-superclasses nil direct-superclasses-p) + ((class structure-class) slot-names &key + (direct-superclasses nil direct-superclasses-p) (direct-slots nil direct-slots-p) - direct-default-initargs - (predicate-name nil predicate-name-p)) + direct-default-initargs) (declare (ignore slot-names direct-default-initargs)) (if direct-superclasses-p (setf (slot-value class 'direct-superclasses) @@ -736,14 +718,6 @@ (setf (slot-value class 'wrapper) (classoid-layout lclass))) (setf (slot-value class 'finalized-p) t) (update-pv-table-cache-info class) - (setq predicate-name (if predicate-name-p - (setf (slot-value class 'predicate-name) - (car predicate-name)) - (or (slot-value class 'predicate-name) - (setf (slot-value class 'predicate-name) - (make-class-predicate-name - (class-name class)))))) - (make-class-predicate class predicate-name) (add-slot-accessors class direct-slots))) (defmethod direct-slot-definition-class ((class structure-class) &rest initargs) @@ -1041,9 +1015,9 @@ ;; do if we find that said user has added a slot ;; with the same name as another slot... (cell (or (assq name (class-slot-cells from-class)) - (setf (class-slot-cells from-class) - (cons (cons name +slot-unbound+) - (class-slot-cells from-class)))))) + (let ((c (cons name +slot-unbound+))) + (push c (class-slot-cells from-class)) + c)))) (aver (consp cell)) (if (eq +slot-unbound+ (cdr cell)) ;; We may have inherited an initfunction diff --git a/tests/interface.impure.lisp b/tests/interface.impure.lisp index 22a9ace..406dfba 100644 --- a/tests/interface.impure.lisp +++ b/tests/interface.impure.lisp @@ -23,18 +23,10 @@ (assert (string= (documentation #'(setf foo) 'function) "(setf foo) documentation")) -(defun (sb-pcl::class-predicate foo) (x) - "(class-predicate foo) documentation" - x) - (assert (string= (documentation '(setf foo) 'function) "(setf foo) documentation")) (assert (string= (documentation #'(setf foo) 'function) "(setf foo) documentation")) -(assert (string= (documentation '(sb-pcl::class-predicate foo) 'function) - "(class-predicate foo) documentation")) -(assert (string= (documentation #'(sb-pcl::class-predicate foo) 'function) - "(class-predicate foo) documentation")) ;;; DISASSEMBLE shouldn't fail on closures or unpurified functions (defun disassemble-fun (x) x) diff --git a/version.lisp-expr b/version.lisp-expr index 6d9232f..61a9def 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.7.9" +"0.9.7.10"