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).
(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
(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)
(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 ()
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))))))
\f
(defmacro wrapper-of-macro (x)
`(layout-of ,x))
(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)
;;;; 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
(defvar *standard-method-combination*)
\f
-(defun make-class-predicate-name (name)
- (list 'class-predicate name))
-
(defun plist-value (object name)
(getf (object-plist object) name))
: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
:reader class-direct-subclasses)
(direct-methods
:initform (cons nil nil))
- (predicate-name
- :initform nil
- :reader class-predicate-name)
(documentation
:initform nil
:initarg :documentation)
(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)))
(defgeneric class-precedence-list (pcl-class))
-(defgeneric class-predicate-name (class))
-
(defgeneric class-wrapper (pcl-class))
(defgeneric definition-source (definition-source-mixin))
(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))
(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))
\f
;;; This DEFVAR was originally in defs.lisp, now moved here.
;;;
(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
(/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)))
(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))
\f
(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
(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))
(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))
(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:
;;
(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)
(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)
;; 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
(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"))
\f
;;; DISASSEMBLE shouldn't fail on closures or unpurified functions
(defun disassemble-fun (x) x)
;;; 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"
projects / sbcl.git / commitdiff