X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefclass.lisp;h=5d79f0e2a049e949eba4da98d05115553a52c177;hb=d25e3478acccec70402ff32554669a982be8e281;hp=8dc0529f20e722d7190d3144b83814cc254c3c13;hpb=f4e8bca5eaa6e6db42299fe2f3852fb2e07508c7;p=sbcl.git diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 8dc0529..5d79f0e 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -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*)) @@ -117,51 +119,51 @@ ,defclass-form)))))))) (defun canonize-defclass-options (class-name options) - (macrolet ((assert-single (option) - `(when ,option - (error "Multiple ~A options in DEFCLASS ~S." - ,(intern (string option) :keyword) - class-name)))) - (let (metaclass - default-initargs - documentation - canonized-options) + (maplist (lambda (sublist) + (let ((option-name (first (pop sublist)))) + (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 + default-initargs + documentation + canonized-options) (dolist (option options) (unless (listp option) (error "~S is not a legal defclass option." option)) (case (first option) - (:metaclass - (assert-single 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 - (assert-single 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 "~@" + name ~S in :DEFAULT-INITARGS of ~ + 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 - (assert-single documentation) (unless (stringp (second option)) (error "~S is not a legal :documentation value" (second option))) (setf documentation t) (push `(:documentation ,(second option)) canonized-options)) (otherwise (push `(',(car option) ',(cdr option)) canonized-options)))) - (values (or metaclass 'standard-class) (nreverse canonized-options))))) + (values (or metaclass 'standard-class) (nreverse canonized-options)))) (defun canonize-defclass-slots (class-name slots env) (let (canonized-specs) @@ -182,14 +184,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*)) @@ -203,7 +206,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))) @@ -212,10 +215,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)))))) @@ -224,8 +229,17 @@ ((null head)) (unless (cdr (second head)) (setf (second head) (car (second head))))) - (let ((canon `(:name ',name :readers ',readers :writers ',writers - :initargs ',initargs ',others))) + (let* ((type-check-function + (if (eq type t) + nil + `('type-check-function (lambda (value) + (declare (type ,type value) + (optimize (sb-c:store-coverage-data 0))) + value)))) + (canon `(:name ',name :readers ',readers :writers ',writers + :initargs ',initargs + ,@type-check-function + ',others))) (push (if (eq initform unsupplied) `(list* ,@canon) `(list* :initfunction ,(make-initfunction initform) @@ -247,30 +261,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 @@ -329,14 +346,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)) @@ -349,11 +366,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))) @@ -362,50 +379,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) @@ -429,7 +446,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)) @@ -437,7 +454,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))) @@ -456,7 +473,7 @@ (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) @@ -464,20 +481,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))