X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefclass.lisp;h=33bfd0b1a3024063326c7942436f413e21d406b9;hb=4ba392170e98744f0ef0b8e08a5d42b988f1d0c9;hp=cf7562a5b2c280fdda12f8d95e98ec886272835a;hpb=f51e60af46a5133d791f3f303f2057380181aca1;p=sbcl.git diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index cf7562a..33bfd0b 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -53,7 +53,7 @@ ;; DEFSTRUCT-P should be true if the class is defined ;; with a metaclass STRUCTURE-CLASS, so that a DEFSTRUCT ;; is compiled for the class. - (defstruct-p (and (eq *boot-state* 'complete) + (defstruct-p (and (eq **boot-state** 'complete) (let ((mclass (find-class metaclass nil))) (and mclass (*subtypep @@ -71,7 +71,9 @@ canonical-options)) ',*readers-for-this-defclass* ',*writers-for-this-defclass* - ',*slot-names-for-this-defclass*)))) + ',*slot-names-for-this-defclass* + (sb-c:source-location) + ',(safe-code-p env))))) (if defstruct-p (progn ;; FIXME: (YUK!) Why do we do this? Because in order @@ -86,7 +88,7 @@ ;; then use CLASS-DIRECT-SLOTS. -- CSR, 2002-06-07 (eval defclass-form) (let* ((include (or (and direct-superclasses - (fix-super (car direct-superclasses))) + (find-class (car direct-superclasses) nil)) (and (not (eq name 'structure-object)) *the-class-structure-object*))) (defstruct-form (make-structure-class-defstruct-form @@ -109,7 +111,7 @@ ;; full-blown class, so the "a class of this name is ;; coming" note we write here would be irrelevant. (eval-when (:compile-toplevel) - (%compiler-defclass ',name + (%compiler-defclass ',name ',*readers-for-this-defclass* ',*writers-for-this-defclass* ',*slot-names-for-this-defclass*)) @@ -119,11 +121,12 @@ (defun canonize-defclass-options (class-name options) (maplist (lambda (sublist) (let ((option-name (first (pop sublist)))) - (when (member option-name sublist :key #'first) - (error "Multiple ~S options in DEFCLASS ~S." - option-name class-name)))) + (when (member option-name sublist :key #'first :test #'eq) + (error 'simple-program-error + :format-control "Multiple ~S options in DEFCLASS ~S." + :format-arguments (list option-name class-name))))) options) - (let (metaclass + (let (metaclass default-initargs documentation canonized-options) @@ -131,26 +134,27 @@ (unless (listp option) (error "~S is not a legal defclass option." option)) (case (first option) - (:metaclass + (:metaclass (let ((maybe-metaclass (second option))) (unless (and maybe-metaclass (legal-class-name-p maybe-metaclass)) - (error "~@" - maybe-metaclass)) + :format-arguments (list maybe-metaclass))) (setf metaclass maybe-metaclass))) (:default-initargs (let (initargs arg-names) (doplist (key val) (cdr option) - (when (member key arg-names) - (error 'simple-program-error + (when (member key arg-names :test #'eq) + (error 'simple-program-error :format-control "~@" + DEFCLASS ~S.~:>" :format-arguments (list key class-name))) (push key arg-names) - (push ``(,',key ,,(make-initfunction val) ,',val) initargs)) + (push ``(,',key ,',val ,,(make-initfunction val)) initargs)) (setf default-initargs t) - (push `(:direct-default-initargs (list ,@(nreverse initargs))) + (push `(:direct-default-initargs (list ,@(nreverse initargs))) canonized-options))) (:documentation (unless (stringp (second option)) @@ -159,6 +163,8 @@ (push `(:documentation ,(second option)) canonized-options)) (otherwise (push `(',(car option) ',(cdr option)) canonized-options)))) + (unless default-initargs + (push '(:direct-default-initargs nil) canonized-options)) (values (or metaclass 'standard-class) (nreverse canonized-options)))) (defun canonize-defclass-slots (class-name slots env) @@ -180,14 +186,15 @@ (initargs ()) (others ()) (unsupplied (list nil)) + (type t) (initform unsupplied)) (check-slot-name-for-defclass name class-name env) (push name *slot-names-for-this-defclass*) (flet ((note-reader (x) (unless (symbolp x) - (error 'simple-program-error + (error 'simple-program-error :format-control "Slot reader name ~S for slot ~S in ~ - DEFCLASS ~S is not a symbol." + DEFCLASS ~S is not a symbol." :format-arguments (list x name class-name))) (push x readers) (push x *readers-for-this-defclass*)) @@ -201,7 +208,7 @@ (:writer (note-writer val)) (:initarg (unless (symbolp val) - (error 'simple-program-error + (error 'simple-program-error :format-control "Slot initarg name ~S for slot ~S in ~ DEFCLASS ~S is not a symbol." :format-arguments (list val name class-name))) @@ -210,10 +217,12 @@ (when (member key '(:initform :allocation :type :documentation)) (when (eq key :initform) (setf initform val)) + (when (eq key :type) + (setf type val)) (when (get-properties others (list key)) - (error 'simple-program-error + (error 'simple-program-error :format-control "Duplicate slot option ~S for slot ~ - ~S in DEFCLASS ~S." + ~S in DEFCLASS ~S." :format-arguments (list key name class-name)))) ;; For non-standard options multiple entries go in a list (push val (getf others key)))))) @@ -245,30 +254,33 @@ (slot-name-illegal "a keyword")) ((constantp name env) (slot-name-illegal "a constant")) - ((member name *slot-names-for-this-defclass*) - (error 'simple-program-error + ((member name *slot-names-for-this-defclass* :test #'eq) + (error 'simple-program-error :format-control "Multiple slots named ~S in DEFCLASS ~S." :format-arguments (list name class-name)))))) (defun make-initfunction (initform) (cond ((or (eq initform t) - (equal initform ''t)) - '(function constantly-t)) - ((or (eq initform nil) - (equal initform ''nil)) - '(function constantly-nil)) - ((or (eql initform 0) - (equal initform ''0)) - '(function constantly-0)) - (t - (let ((entry (assoc initform *initfunctions-for-this-defclass* - :test #'equal))) - (unless entry - (setq entry (list initform - (gensym) - `(function (lambda () ,initform)))) - (push entry *initfunctions-for-this-defclass*)) - (cadr entry))))) + (equal initform ''t)) + '(function constantly-t)) + ((or (eq initform nil) + (equal initform ''nil)) + '(function constantly-nil)) + ((or (eql initform 0) + (equal initform ''0)) + '(function constantly-0)) + (t + (let ((entry (assoc initform *initfunctions-for-this-defclass* + :test #'equal))) + (unless entry + (setq entry (list initform + (gensym) + `(function (lambda () + (declare (optimize + (sb-c:store-coverage-data 0))) + ,initform)))) + (push entry *initfunctions-for-this-defclass*)) + (cadr entry))))) (defun %compiler-defclass (name readers writers slots) ;; ANSI says (Macro DEFCLASS, section 7.7) that DEFCLASS, if it @@ -286,6 +298,7 @@ ;; actual type as a compile-time side-effect would probably be a bad ;; idea and (2) anyway we don't need to modify it in order to make ;; NAME be recognized as a valid type name) + (with-single-package-locked-error (:symbol name "proclaiming ~S as a class")) (unless (info :type :kind name) ;; Tell the compiler to expect a class with the given NAME, by ;; writing a kind of minimal placeholder type information. This @@ -327,14 +340,14 @@ (error "~S is not a class in *early-class-definitions*." class-name))) (defun make-early-class-definition - (name source metaclass - superclass-names canonical-slots other-initargs) + (name source-location metaclass + superclass-names canonical-slots other-initargs) (list 'early-class-definition - name source metaclass - superclass-names canonical-slots other-initargs)) + name source-location metaclass + superclass-names canonical-slots other-initargs)) (defun ecd-class-name (ecd) (nth 1 ecd)) -(defun ecd-source (ecd) (nth 2 ecd)) +(defun ecd-source-location (ecd) (nth 2 ecd)) (defun ecd-metaclass (ecd) (nth 3 ecd)) (defun ecd-superclass-names (ecd) (nth 4 ecd)) (defun ecd-canonical-slots (ecd) (nth 5 ecd)) @@ -347,11 +360,11 @@ (defun early-class-slots (class-name) (cdr (or (assoc class-name *early-class-slots*) - (let ((a (cons class-name - (mapcar #'canonical-slot-name - (early-collect-inheritance class-name))))) - (push a *early-class-slots*) - a)))) + (let ((a (cons class-name + (mapcar #'canonical-slot-name + (early-collect-inheritance class-name))))) + (push a *early-class-slots*) + a)))) (defun early-class-size (class-name) (length (early-class-slots class-name))) @@ -360,50 +373,50 @@ ;;(declare (values slots cpl default-initargs direct-subclasses)) (let ((cpl (early-collect-cpl class-name))) (values (early-collect-slots cpl) - cpl - (early-collect-default-initargs cpl) - (let (collect) - (dolist (definition *early-class-definitions*) - (when (memq class-name (ecd-superclass-names definition)) - (push (ecd-class-name definition) collect))) + cpl + (early-collect-default-initargs cpl) + (let (collect) + (dolist (definition *early-class-definitions*) + (when (memq class-name (ecd-superclass-names definition)) + (push (ecd-class-name definition) collect))) (nreverse collect))))) (defun early-collect-slots (cpl) (let* ((definitions (mapcar #'early-class-definition cpl)) - (super-slots (mapcar #'ecd-canonical-slots definitions)) - (slots (apply #'append (reverse super-slots)))) + (super-slots (mapcar #'ecd-canonical-slots definitions)) + (slots (apply #'append (reverse super-slots)))) (dolist (s1 slots) (let ((name1 (canonical-slot-name s1))) - (dolist (s2 (cdr (memq s1 slots))) - (when (eq name1 (canonical-slot-name s2)) - (error "More than one early class defines a slot with the~%~ - name ~S. This can't work because the bootstrap~%~ - object system doesn't know how to compute effective~%~ - slots." - name1))))) + (dolist (s2 (cdr (memq s1 slots))) + (when (eq name1 (canonical-slot-name s2)) + (error "More than one early class defines a slot with the~%~ + name ~S. This can't work because the bootstrap~%~ + object system doesn't know how to compute effective~%~ + slots." + name1))))) slots)) (defun early-collect-cpl (class-name) (labels ((walk (c) - (let* ((definition (early-class-definition c)) - (supers (ecd-superclass-names definition))) - (cons c - (apply #'append (mapcar #'early-collect-cpl supers)))))) + (let* ((definition (early-class-definition c)) + (supers (ecd-superclass-names definition))) + (cons c + (apply #'append (mapcar #'early-collect-cpl supers)))))) (remove-duplicates (walk class-name) :from-end nil :test #'eq))) (defun early-collect-default-initargs (cpl) (let ((default-initargs ())) (dolist (class-name cpl) (let* ((definition (early-class-definition class-name)) - (others (ecd-other-initargs definition))) - (loop (when (null others) (return nil)) - (let ((initarg (pop others))) - (unless (eq initarg :direct-default-initargs) - (error "~@" - initarg))) - (setq default-initargs - (nconc default-initargs (reverse (pop others))))))) + (others (ecd-other-initargs definition))) + (loop (when (null others) (return nil)) + (let ((initarg (pop others))) + (unless (eq initarg :direct-default-initargs) + (error "~@" + initarg))) + (setq default-initargs + (nconc default-initargs (reverse (pop others))))))) (reverse default-initargs))) (defun !bootstrap-slot-index (class-name slot-name) @@ -427,7 +440,7 @@ ;;; by the full object system later. (defmacro !bootstrap-get-slot (type object slot-name) `(clos-slots-ref (get-slots ,object) - (!bootstrap-slot-index ,type ,slot-name))) + (!bootstrap-slot-index ,type ,slot-name))) (defun !bootstrap-set-slot (type object slot-name new-value) (setf (!bootstrap-get-slot type object slot-name) new-value)) @@ -435,7 +448,7 @@ (!bootstrap-get-slot 'class class 'name)) (defun early-class-precedence-list (class) - (!bootstrap-get-slot 'pcl-class class 'class-precedence-list)) + (!bootstrap-get-slot 'pcl-class class '%class-precedence-list)) (defun early-class-name-of (instance) (early-class-name (class-of instance))) @@ -449,12 +462,15 @@ (defun early-slot-definition-location (slotd) (!bootstrap-get-slot 'standard-effective-slot-definition slotd 'location)) +(defun early-slot-definition-info (slotd) + (!bootstrap-get-slot 'standard-effective-slot-definition slotd 'info)) + (defun early-accessor-method-slot-name (method) (!bootstrap-get-slot 'standard-accessor-method method 'slot-name)) (unless (fboundp 'class-name-of) (setf (symbol-function 'class-name-of) - (symbol-function 'early-class-name-of))) + (symbol-function 'early-class-name-of))) (unintern 'early-class-name-of) (defun early-class-direct-subclasses (class) @@ -462,20 +478,23 @@ (declaim (notinline load-defclass)) (defun load-defclass (name metaclass supers canonical-slots canonical-options - readers writers slot-names) + readers writers slot-names source-location safe-p) + ;; SAFE-P is used by REAL-LOAD-DEFCLASS, but can be ignored here, since + ;; during the bootstrap we won't have (SAFETY 3). + (declare (ignore safe-p)) (%compiler-defclass name readers writers slot-names) (setq supers (copy-tree supers) - canonical-slots (copy-tree canonical-slots) - canonical-options (copy-tree canonical-options)) + canonical-slots (copy-tree canonical-slots) + canonical-options (copy-tree canonical-options)) (let ((ecd - (make-early-class-definition name - *load-pathname* - metaclass - supers - canonical-slots - canonical-options)) - (existing - (find name *early-class-definitions* :key #'ecd-class-name))) + (make-early-class-definition name + source-location + metaclass + supers + canonical-slots + canonical-options)) + (existing + (find name *early-class-definitions* :key #'ecd-class-name))) (setq *early-class-definitions* - (cons ecd (remove existing *early-class-definitions*))) + (cons ecd (remove existing *early-class-definitions*))) ecd))