X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefclass.lisp;h=845edaf2ea3bdca835ae1762650c972b054f5970;hb=e8b69b1dd5564a4237b1bdc1060820c3b820cde2;hp=9d5ee2c075fb5696af8058b35efdde188b5faf70;hpb=d5aafdd8ab6387e12bac187048ed322bc96fb79a;p=sbcl.git diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 9d5ee2c..845edaf 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -44,21 +44,14 @@ ;;; ;;; After the metabraid has been setup, and the protocol for defining ;;; classes has been defined, the real definition of LOAD-DEFCLASS is -;;; installed by the file defclass.lisp -(defmacro defclass (name direct-superclasses direct-slots &rest options) - (expand-defclass name direct-superclasses direct-slots options)) - -(defun expand-defclass (name supers slots options) - ;; FIXME: We should probably just ensure that the relevant - ;; DEFVAR/DEFPARAMETERs occur before this definition, rather - ;; than locally declaring them SPECIAL. - (declare (special *boot-state* *the-class-structure-class*)) - (setq supers (copy-tree supers) - slots (copy-tree slots) - options (copy-tree options)) - (let ((metaclass 'standard-class)) - (dolist (option options) - (if (not (listp option)) +;;; installed by the file std-class.lisp +(defmacro defclass (name %direct-superclasses %direct-slots &rest %options) + (let ((supers (copy-tree %direct-superclasses)) + (slots (copy-tree %direct-slots)) + (options (copy-tree %options))) + (let ((metaclass 'standard-class)) + (dolist (option options) + (if (not (listp option)) (error "~S is not a legal defclass option." option) (when (eq (car option) ':metaclass) (unless (legal-class-name-p (cadr option)) @@ -66,59 +59,94 @@ legal class name." (cadr option))) (setq metaclass - (case (cadr option) - (cl:standard-class 'standard-class) - (cl:structure-class 'structure-class) - (t (cadr option)))) + (case (cadr option) + (cl:standard-class 'standard-class) + (cl:structure-class 'structure-class) + (t (cadr option)))) (setf options (remove option options)) (return t)))) - (let ((*initfunctions* ()) - (*readers* ()) ;Truly a crock, but we got - (*writers* ())) ;to have it to live nicely. - (declare (special *initfunctions* *readers* *writers*)) - (let ((canonical-slots - (mapcar #'(lambda (spec) - (canonicalize-slot-specification name spec)) - slots)) - (other-initargs - (mapcar #'(lambda (option) - (canonicalize-defclass-option name option)) - options)) - (defstruct-p (and (eq *boot-state* 'complete) - (let ((mclass (find-class metaclass nil))) - (and mclass - (*subtypep - mclass - *the-class-structure-class*)))))) - (let ((defclass-form - (eval-when (:load-toplevel :execute) - `(progn - ,@(mapcar #'(lambda (x) + (let ((*initfunctions* ()) + (*readers* ()) ;Truly a crock, but we got + (*writers* ())) ;to have it to live nicely. + (declare (special *initfunctions* *readers* *writers*)) + (let ((canonical-slots + (mapcar #'(lambda (spec) + (canonicalize-slot-specification name spec)) + slots)) + (other-initargs + (mapcar #'(lambda (option) + (canonicalize-defclass-option name option)) + options)) + ;; DEFSTRUCT-P should be true, if the class is defined with a + ;; metaclass STRUCTURE-CLASS, such that a DEFSTRUCT is compiled + ;; for the class. + (defstruct-p (and (eq *boot-state* 'complete) + (let ((mclass (find-class metaclass nil))) + (and mclass + (*subtypep + mclass + *the-class-structure-class*)))))) + (let ((defclass-form + `(progn + ,@(mapcar (lambda (x) `(declaim (ftype (function (t) t) ,x))) - *readers*) - ,@(mapcar #'(lambda (x) + *readers*) + ,@(mapcar (lambda (x) `(declaim (ftype (function (t t) t) ,x))) - *writers*) - (let ,(mapcar #'cdr *initfunctions*) - (load-defclass ',name - ',metaclass - ',supers - (list ,@canonical-slots) - (list ,@(apply #'append - (when defstruct-p - '(:from-defclass-p t)) - other-initargs)))))))) - (if defstruct-p - (progn - (eval defclass-form) ; Define the class now, so that.. - `(progn ; ..the defstruct can be compiled. - ,(class-defstruct-form (find-class name)) - ,defclass-form)) - (progn - (when (eq *boot-state* 'complete) - (inform-type-system-about-std-class name)) - defclass-form))))))) + *writers*) + (let ,(mapcar #'cdr *initfunctions*) + (load-defclass ',name + ',metaclass + ',supers + (list ,@canonical-slots) + (list ,@(apply #'append + (when defstruct-p + '(:from-defclass-p t)) + other-initargs))))))) + (if defstruct-p + (let* ((include (or (and supers + (fix-super (car supers))) + (and (not (eq name 'structure-object)) + *the-class-structure-object*))) + (defstruct-form (make-structure-class-defstruct-form + name slots include))) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + ,defstruct-form) ; really compile the defstruct-form + (eval-when (:compile-toplevel :load-toplevel :execute) + ,defclass-form))) + `(progn + ;; By telling the type system at compile time about + ;; the existence of a class named NAME, we can avoid + ;; various bogus warnings about "type isn't defined yet". + ,(when (and + ;; But it's not so important to get rid of + ;; "not defined yet" warnings during + ;; bootstrapping, and machinery like + ;; INFORM-TYPE-SYSTEM-ABOUT-STD-CLASS + ;; mightn't be defined yet. So punt then. + (eq *boot-state* 'complete) + ;; And although we know enough about + ;; STANDARD-CLASS, and ANSI imposes enough + ;; restrictions on the user overloading its + ;; methods, that (1) we can shortcut the + ;; method dispatch and do an ordinary + ;; function call, and (2) be sure we're getting + ;; it right even when we do it at compile + ;; time; we don't in general know how to do + ;; that for other classes. So punt then too. + (eq metaclass 'standard-class)) + `(eval-when (:compile-toplevel) + ;; we only need :COMPILE-TOPLEVEL here, because this + ;; should happen in the compile-time environment + ;; only. + ;; Later, INFORM-TYPE-SYSTEM-ABOUT-STD-CLASS is + ;; called by way of LOAD-DEFCLASS (calling + ;; ENSURE-CLASS-USING-CLASS) to establish the 'real' + ;; type predicate. + (inform-type-system-about-std-class ',name))) + ,defclass-form)))))))) (defun make-initfunction (initform) (declare (special *initfunctions*)) @@ -246,10 +274,11 @@ (values (early-collect-slots cpl) cpl (early-collect-default-initargs cpl) - (gathering1 (collecting) + (let (collect) (dolist (definition *early-class-definitions*) (when (memq class-name (ecd-superclass-names definition)) - (gather1 (ecd-class-name definition)))))))) + (push (ecd-class-name definition) collect))) + (nreverse collect))))) (defun early-collect-slots (cpl) (let* ((definitions (mapcar #'early-class-definition cpl))