X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fbraid.lisp;h=ae39f214aaba88404baf9c8a968db035e18cd291;hb=43ed30b023d8ea5d0cd9c6a8928b4169aa0275ef;hp=5a808ae860bb75a138ba412b7b2d3b960cb98734;hpb=3ba801e57a919c338466a31a7130c113dbe5ad9b;p=sbcl.git diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 5a808ae..ae39f21 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -219,6 +219,8 @@ name class slots standard-effective-slot-definition-wrapper t)) + (setf (layout-slot-table wrapper) (make-slot-table class slots t)) + (case meta ((standard-class funcallable-standard-class) (!bootstrap-initialize-class @@ -276,6 +278,7 @@ (set-slot 'name name) (set-slot 'finalized-p t) (set-slot 'source source) + (set-slot 'safe-p nil) (set-slot '%type (if (eq class (find-class t)) t ;; FIXME: Could this just be CLASS instead @@ -308,7 +311,11 @@ structure-class condition-class slot-class)) (set-slot 'direct-slots direct-slots) - (set-slot 'slots slots)) + (set-slot 'slots slots) + (setf (layout-slot-table wrapper) + (make-slot-table class slots + (member metaclass-name + '(standard-class funcallable-standard-class))))) ;; For all direct superclasses SUPER of CLASS, make sure CLASS is ;; a direct subclass of SUPER. Note that METACLASS-NAME doesn't @@ -369,6 +376,7 @@ (set-val 'writers (get-val :writers)) (set-val 'allocation :instance) (set-val '%type (or (get-val :type) t)) + (set-val '%type-check-function (get-val 'type-check-function)) (set-val '%documentation (or (get-val :documentation) "")) (set-val '%class class) (when effective-p @@ -425,8 +433,7 @@ (list class-name) (list class-name) "automatically generated boundp method"))) - (let ((gf (ensure-generic-function accessor-name - :lambda-list arglist))) + (let ((gf (ensure-generic-function accessor-name :lambda-list arglist))) (if (find specls (early-gf-methods gf) :key #'early-method-specializers :test 'equal) @@ -515,16 +522,12 @@ (cons name cpl) wrapper prototype)))))) -(defmacro wrapper-of-macro (x) - `(layout-of ,x)) - -(defun class-of (x) - (wrapper-class* (wrapper-of-macro x))) - -;;; FIXME: We probably don't need both WRAPPER-OF and WRAPPER-OF-MACRO. #-sb-fluid (declaim (inline wrapper-of)) (defun wrapper-of (x) - (wrapper-of-macro x)) + (layout-of x)) + +(defun class-of (x) + (wrapper-class* (wrapper-of x))) (defun eval-form (form) (lambda () (eval form))) @@ -589,6 +592,7 @@ (pushnew 'ensure-deffoo-class sb-kernel::*defstruct-hooks*) (pushnew 'ensure-deffoo-class sb-kernel::*define-condition-hooks*) +;;; FIXME: only needed during bootstrap (defun make-class-predicate (class name) (let* ((gf (ensure-generic-function name :lambda-list '(object))) (mlist (if (eq *boot-state* 'complete) @@ -597,8 +601,8 @@ (unless mlist (unless (eq class *the-class-t*) (let* ((default-method-function #'constantly-nil) - (default-method-initargs (list :function - default-method-function)) + (default-method-initargs (list :function default-method-function + 'plist '(:constant-value nil))) (default-method (make-a-method 'standard-method () @@ -606,19 +610,16 @@ (list *the-class-t*) default-method-initargs "class predicate default method"))) - (setf (method-function-get default-method-function :constant-value) - nil) (add-method gf default-method))) (let* ((class-method-function #'constantly-t) - (class-method-initargs (list :function - class-method-function)) + (class-method-initargs (list :function class-method-function + 'plist '(:constant-value t))) (class-method (make-a-method 'standard-method () (list 'object) (list class) class-method-initargs "class predicate class method"))) - (setf (method-function-get class-method-function :constant-value) t) (add-method gf class-method))) gf)) @@ -671,24 +672,24 @@ (!bootstrap-class-predicates nil) (!bootstrap-built-in-classes) -(dohash (name x *find-class*) - (let* ((class (find-class-from-cell name x)) - (layout (class-wrapper class)) - (lclass (layout-classoid layout)) - (lclass-pcl-class (classoid-pcl-class lclass)) - (olclass (find-classoid name nil))) - (if lclass-pcl-class - (aver (eq class lclass-pcl-class)) - (setf (classoid-pcl-class lclass) class)) +(dohash ((name x) *find-class*) + (let* ((class (find-class-from-cell name x)) + (layout (class-wrapper class)) + (lclass (layout-classoid layout)) + (lclass-pcl-class (classoid-pcl-class lclass)) + (olclass (find-classoid name nil))) + (if lclass-pcl-class + (aver (eq class lclass-pcl-class)) + (setf (classoid-pcl-class lclass) class)) - (update-lisp-class-layout class layout) + (update-lisp-class-layout class layout) - (cond (olclass - (aver (eq lclass olclass))) - (t - (setf (find-classoid name) lclass))) + (cond (olclass + (aver (eq lclass olclass))) + (t + (setf (find-classoid name) lclass))) - (set-class-type-translation class name))) + (set-class-type-translation class name))) (setq *boot-state* 'braid) @@ -710,11 +711,18 @@ ;;; :BEFORE method, it would seem that going through ;;; NO-APPLICABLE-METHOD is prohibited, as in fact there is an ;;; applicable method. -- CSR, 2002-11-15 +(define-condition no-primary-method (reference-condition error) + ((generic-function :initarg :generic-function :reader no-primary-method-generic-function) + (args :initarg :args :reader no-primary-method-args)) + (:report + (lambda (c s) + (format s "~@" + (no-primary-method-generic-function c) + (no-primary-method-args c)))) + (:default-initargs :references (list '(:ansi-cl :section (7 6 6 2))))) (defmethod no-primary-method (generic-function &rest args) - (error "~@" - generic-function - args)) + (error 'no-primary-method :generic-function generic-function :args args)) (defmethod invalid-qualifiers ((gf generic-function) combin