X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefclass.lisp;h=bcfb77b1bc3f9662d45430fd4e44da9d28ca57cd;hb=5251267b300cb967cbf547e838037a616064bd58;hp=99fcb3dd1440354f751507366e63dfcb648ca589;hpb=2abf77f6c4c559a3e5b7fc351a4743305381feb6;p=sbcl.git diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 99fcb3d..bcfb77b 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -23,38 +23,6 @@ (in-package "SB-PCL") -;;; MAKE-TOP-LEVEL-FORM is used by all PCL macros that appear `at top-level'. -;;; -;;; The original motiviation for this function was to deal with the -;;; bug in the Genera compiler that prevents lambda expressions in -;;; top-level forms other than DEFUN from being compiled. -;;; -;;; Now this function is used to grab other functionality as well. This -;;; includes: -;;; - Preventing the grouping of top-level forms. For example, a -;;; DEFCLASS followed by a DEFMETHOD may not want to be grouped -;;; into the same top-level form. -;;; - Telling the programming environment what the pretty version -;;; of the name of this form is. This is used by WARN. -;;; -;;; FIXME: It's not clear that this adds value any more. Couldn't -;;; we just use EVAL-WHEN? -(defun make-top-level-form (name times form) - (flet ((definition-name () - (if (and (listp name) - (memq (car name) - '(defmethod defclass class - method method-combination))) - (format nil "~A~{ ~S~}" - (capitalize-words (car name) ()) (cdr name)) - (format nil "~S" name)))) - ;; FIXME: It appears that we're just consing up a string and then - ;; throwing it away?! - (definition-name) - (if (or (member 'compile times) - (member ':compile-toplevel times)) - `(eval-when ,times ,form) - form))) (defun make-progn (&rest forms) (let ((progn-form nil)) @@ -76,13 +44,11 @@ ;;; ;;; 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 +;;; installed by the file std-class.lisp (defmacro defclass (name direct-superclasses direct-slots &rest options) - (declare (indentation 2 4 3 1)) (expand-defclass name direct-superclasses direct-slots options)) (defun expand-defclass (name supers slots options) - (declare (special *defclass-times* *boot-state* *the-class-structure-class*)) (setq supers (copy-tree supers) slots (copy-tree slots) options (copy-tree options)) @@ -104,10 +70,9 @@ (return t)))) (let ((*initfunctions* ()) - (*accessors* ()) ;Truly a crock, but we got - (*readers* ()) ;to have it to live nicely. - (*writers* ())) - (declare (special *initfunctions* *accessors* *readers* *writers*)) + (*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)) @@ -119,31 +84,37 @@ (defstruct-p (and (eq *boot-state* 'complete) (let ((mclass (find-class metaclass nil))) (and mclass - (*subtypep mclass - *the-class-structure-class*)))))) - (do-standard-defsetfs-for-defclass *accessors*) + (*subtypep + mclass + *the-class-structure-class*)))))) (let ((defclass-form - (make-top-level-form `(defclass ,name) - (if defstruct-p '(:load-toplevel :execute) *defclass-times*) - `(progn - ,@(mapcar #'(lambda (x) - `(declaim (ftype (function (t) t) ,x))) - *readers*) - ,@(mapcar #'(lambda (x) - #-setf (when (consp x) - (setq x (get-setf-function-name (cadr 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)) - ',*accessors*)))))) + `(progn + ,@(mapcar (lambda (x) + `(declaim (ftype (function (t) t) ,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))))))) + ;; FIXME: The way that we do things like (EVAL DEFCLASS-FORM) + ;; here is un-ANSI-Common-Lisp-y and leads to problems + ;; (like DEFUN for the type predicate being called more than + ;; once when we do DEFCLASS at the interpreter prompt), + ;; causing bogus style warnings. It would be better to + ;; rewrite this so that the macroexpansion looks like e.g. + ;; (PROGN + ;; (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) + ;; (FROB1 ..)) + ;; (EVAL-WHEN (:LOAD-TOPLEVEL :EXECUTE) + ;; (FROB2 ..))) (if defstruct-p (progn (eval defclass-form) ; Define the class now, so that.. @@ -151,22 +122,37 @@ ,(class-defstruct-form (find-class name)) ,defclass-form)) (progn - (when (and (eq *boot-state* 'complete) - (not (member 'compile *defclass-times*))) + (when (eq *boot-state* 'complete) + ;; FIXME: MNA (on sbcl-devel 2001-05-30) reported + ;; (if I understand correctly -- WHN) that this call + ;; is directly responsible for defining + ;; class-predicates which always return + ;; CONSTANTLY-NIL in the compile-time environment, + ;; and is indirectly responsible for bogus warnings + ;; about redefinitions when making definitions in + ;; the interpreter. I didn't like his fix (deleting + ;; the call) since I think the type system *should* + ;; be informed about class definitions here. And I'm + ;; not eager to look too deeply into this sort of + ;; done-too-many-times-in-the-interpreter problem + ;; right now, since it should be easier to make a + ;; clean fix when EVAL-WHEN is made more ANSI (as + ;; per the IR1 section in the BUGS file). But + ;; at some point this should be cleaned up. (inform-type-system-about-std-class name)) defclass-form))))))) (defun make-initfunction (initform) (declare (special *initfunctions*)) - (cond ((or (eq initform 't) + (cond ((or (eq initform t) (equal initform ''t)) - '(function true)) - ((or (eq initform 'nil) + '(function constantly-t)) + ((or (eq initform nil) (equal initform ''nil)) - '(function false)) - ((or (eql initform '0) + '(function constantly-nil)) + ((or (eql initform 0) (equal initform ''0)) - '(function zero)) + '(function constantly-0)) (t (let ((entry (assoc initform *initfunctions* :test #'equal))) (unless entry @@ -177,7 +163,7 @@ (cadr entry))))) (defun canonicalize-slot-specification (class-name spec) - (declare (special *accessors* *readers* *writers*)) + (declare (special *readers* *writers*)) (cond ((and (symbolp spec) (not (keywordp spec)) (not (memq spec '(t nil)))) @@ -199,8 +185,7 @@ (initform (getf spec :initform unsupplied))) (doplist (key val) spec (case key - (:accessor (push val *accessors*) - (push val readers) + (:accessor (push val readers) (push `(setf ,val) writers)) (:reader (push val readers)) (:writer (push val writers)) @@ -319,8 +304,8 @@ (loop (when (null others) (return nil)) (let ((initarg (pop others))) (unless (eq initarg :direct-default-initargs) - (error "The defclass option ~S is not supported by the bootstrap~%~ - object system." + (error "~@" initarg))) (setq default-initargs (nconc default-initargs (reverse (pop others))))))) @@ -346,7 +331,8 @@ ;;; standard slots must be computed the same way in this file as it is ;;; by the full object system later. (defmacro !bootstrap-get-slot (type object slot-name) - `(instance-ref (get-slots ,object) (!bootstrap-slot-index ,type ,slot-name))) + `(clos-slots-ref (get-slots ,object) + (!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)) @@ -374,18 +360,16 @@ (unless (fboundp 'class-name-of) (setf (symbol-function 'class-name-of) (symbol-function 'early-class-name-of))) -;;; FIXME: Can we then delete EARLY-CLASS-NAME-OF? +(unintern 'early-class-name-of) (defun early-class-direct-subclasses (class) (!bootstrap-get-slot 'class class 'direct-subclasses)) (declaim (notinline load-defclass)) -(defun load-defclass - (name metaclass supers canonical-slots canonical-options accessor-names) +(defun load-defclass (name metaclass supers canonical-slots canonical-options) (setq supers (copy-tree supers) canonical-slots (copy-tree canonical-slots) canonical-options (copy-tree canonical-options)) - (do-standard-defsetfs-for-defclass accessor-names) (when (eq metaclass 'standard-class) (inform-type-system-about-std-class name)) (let ((ecd