X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefclass.lisp;h=2c1dfeddca4803f70627cc70ca7e3e5990ffead8;hb=2d3cb6dba6461e98744eca2a1df4f770cea468ca;hp=96aa2fadf9b2709ae50576b64a1e41205ac8932e;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 96aa2fa..2c1dfed 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -23,168 +23,174 @@ (in-package "SB-PCL") -;;; MAKE-TOP-LEVEL-FORM is used by all PCL macros that appear `at top-level'. +;;;; DEFCLASS macro and close personal friends + +;;; ANSI says (Macro DEFCLASS, section 7.7) that DEFCLASS, if it +;;; "appears as a top level form, the compiler must make the class +;;; name be recognized as a valid type name in subsequent declarations +;;; (as for deftype) and be recognized as a valid class name for +;;; defmethod parameter specializers and for use as the :metaclass +;;; option of a subsequent defclass." +(defun preinform-compiler-about-class-type (name) + ;; Unless the type system already has an actual type attached to + ;; NAME (in which case (1) writing a placeholder value over that + ;; 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) + (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 + ;; placeholder will be overwritten later when the class is defined. + (setf (info :type :kind name) :forthcoming-defclass-type)) + (values)) + +;;; state for the current DEFCLASS expansion +(defvar *initfunctions-for-this-defclass*) +(defvar *readers-for-this-defclass*) +(defvar *writers-for-this-defclass*) +(defvar *slot-names-for-this-defclass*) + +;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is +;;; fixed. DEFCLASS always expands into a call to LOAD-DEFCLASS. Until +;;; the meta-braid is set up, LOAD-DEFCLASS has a special definition +;;; which simply collects all class definitions up, when the metabraid +;;; is initialized it is done from those class definitions. ;;; -;;; 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)) - (labels ((collect-forms (forms) - (unless (null forms) - (collect-forms (cdr forms)) - (if (and (listp (car forms)) - (eq (caar forms) 'progn)) - (collect-forms (cdar forms)) - (push (car forms) progn-form))))) - (collect-forms forms) - (cons 'progn progn-form)))) - -;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is fixed. -;;; DEFCLASS always expands into a call to LOAD-DEFCLASS. Until the meta- -;;; braid is set up, LOAD-DEFCLASS has a special definition which simply -;;; collects all class definitions up, when the metabraid is initialized it -;;; is done from those class definitions. -;;; -;;; 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) - (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)) - (let ((metaclass 'standard-class)) - (dolist (option options) - (if (not (listp option)) +;;; 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 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) + (when (eq (car option) :metaclass) (unless (legal-class-name-p (cadr option)) (error "The value of the :metaclass option (~S) is not a~%~ legal class name." (cadr option))) - (setq metaclass - (case (cadr option) - (cl:standard-class 'standard-class) - (cl:structure-class 'structure-class) - (t (cadr option)))) + (setq metaclass (cadr option)) (setf options (remove option options)) (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*)) - (let ((canonical-slots - (mapcar #'(lambda (spec) + (let ((*initfunctions-for-this-defclass* ()) + (*readers-for-this-defclass* ()) ;Truly a crock, but we got + (*writers-for-this-defclass* ()) ;to have it to live nicely. + (*slot-names-for-this-defclass* ())) + (let ((canonical-slots + (mapcar (lambda (spec) (canonicalize-slot-specification name spec)) - slots)) - (other-initargs - (mapcar #'(lambda (option) + 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*)))))) - (do-standard-defsetfs-for-defclass *accessors*) - (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*)))))) - (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 (and (eq *boot-state* 'complete) - (not (member 'compile *defclass-times*))) - (inform-type-system-about-std-class name)) - defclass-form))))))) + options)) + ;; 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) + (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-for-this-defclass*) + ,@(mapcar (lambda (x) + `(declaim (ftype (function (t t) t) ,x))) + *writers-for-this-defclass*) + ,@(mapcar (lambda (x) + `(declaim (ftype (function (t) t) + ,(slot-reader-name x) + ,(slot-boundp-name x)) + (ftype (function (t t) t) + ,(slot-writer-name x)))) + *slot-names-for-this-defclass*) + (let ,(mapcar #'cdr *initfunctions-for-this-defclass*) + (load-defclass ',name + ',metaclass + ',supers + (list ,@canonical-slots) + (list ,@(apply #'append + (when defstruct-p + '(:from-defclass-p t)) + other-initargs))))))) + (if defstruct-p + (progn + ;; FIXME: (YUK!) Why do we do this? Because in order + ;; to make the defstruct form, we need to know what + ;; the accessors for the slots are, so we need + ;; already to have hooked into the CLOS machinery. + ;; + ;; There may be a better way to do this: it would + ;; involve knowing enough about PCL to ask "what + ;; will my slot names and accessors be"; failing + ;; this, we currently just evaluate the whole + ;; kaboodle, and then use CLASS-DIRECT-SLOTS. -- + ;; CSR, 2002-06-07 + (eval defclass-form) + (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 (class-direct-slots (find-class name)) 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" + ;; for code elsewhere in the same file which uses + ;; the name of the type. + ;; + ;; We only need to do this at compile time, because + ;; at load and execute time we write the actual + ;; full-blown class, so the "a class of this name is + ;; coming" note we write here would be irrelevant. + (eval-when (:compile-toplevel) + (preinform-compiler-about-class-type ',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))) + (let ((entry (assoc initform *initfunctions-for-this-defclass* + :test #'equal))) (unless entry (setq entry (list initform (gensym) `(function (lambda () ,initform)))) - (push entry *initfunctions*)) + (push entry *initfunctions-for-this-defclass*)) (cadr entry))))) (defun canonicalize-slot-specification (class-name spec) - (declare (special *accessors* *readers* *writers*)) (cond ((and (symbolp spec) (not (keywordp spec)) (not (memq spec '(t nil)))) + (push spec *slot-names-for-this-defclass*) `'(:name ,spec)) ((not (consp spec)) (error "~S is not a legal slot specification." spec)) ((null (cdr spec)) + (push (car spec) *slot-names-for-this-defclass*) `'(:name ,(car spec))) ((null (cddr spec)) (error "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~ @@ -197,10 +203,10 @@ (initargs ()) (unsupplied (list nil)) (initform (getf spec :initform unsupplied))) + (push name *slot-names-for-this-defclass*) (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)) @@ -209,8 +215,10 @@ (loop (unless (remf spec :reader) (return))) (loop (unless (remf spec :writer) (return))) (loop (unless (remf spec :initarg) (return))) - (setq *writers* (append writers *writers*)) - (setq *readers* (append readers *readers*)) + (setq *writers-for-this-defclass* + (append writers *writers-for-this-defclass*)) + (setq *readers-for-this-defclass* + (append readers *readers-for-this-defclass*)) (setq spec `(:name ',name :readers ',readers :writers ',writers @@ -219,7 +227,7 @@ (if (eq initform unsupplied) `(list* ,@spec) `(list* :initfunction ,(make-initfunction initform) ,@spec)))))) - + (defun canonicalize-defclass-option (class-name option) (declare (ignore class-name)) (case (car option) @@ -230,15 +238,15 @@ (setq key (pop tail) val (pop tail)) (push ``(,',key ,,(make-initfunction val) ,',val) canonical)) - `(':direct-default-initargs (list ,@(nreverse canonical)))))) + `(:direct-default-initargs (list ,@(nreverse canonical)))))) (:documentation `(',(car option) ',(cadr option))) (otherwise `(',(car option) ',(cdr option))))) -;;; This is the early definition of load-defclass. It just collects up -;;; all the class definitions in a list. Later, in the file -;;; braid1.lisp, these are actually defined. +;;; This is the early definition of LOAD-DEFCLASS. It just collects up +;;; all the class definitions in a list. Later, in braid1.lisp, these +;;; are actually defined. ;;; Each entry in *EARLY-CLASS-DEFINITIONS* is an EARLY-CLASS-DEFINITION. (defparameter *early-class-definitions* ()) @@ -283,10 +291,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)) @@ -319,77 +328,75 @@ (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))))))) (reverse default-initargs))) -(defun bootstrap-slot-index (class-name slot-name) +(defun !bootstrap-slot-index (class-name slot-name) (or (position slot-name (early-class-slots class-name)) (error "~S not found" slot-name))) -;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change the -;;; values of slots during bootstrapping. During bootstrapping, there are only -;;; two kinds of objects whose slots we need to access, CLASSes and -;;; SLOT-DEFINITIONs. The first argument to these functions tells whether the -;;; object is a CLASS or a SLOT-DEFINITION. +;;; !BOOTSTRAP-GET-SLOT and !BOOTSTRAP-SET-SLOT are used to access and +;;; change the values of slots during bootstrapping. During +;;; bootstrapping, there are only two kinds of objects whose slots we +;;; need to access, CLASSes and SLOT-DEFINITIONs. The first argument +;;; to these functions tells whether the object is a CLASS or a +;;; SLOT-DEFINITION. ;;; -;;; Note that the way this works it stores the slot in the same place in -;;; memory that the full object system will expect to find it later. This -;;; is critical to the bootstrapping process, the whole changeover to the -;;; full object system is predicated on this. +;;; Note that the way this works it stores the slot in the same place +;;; in memory that the full object system will expect to find it +;;; later. This is critical to the bootstrapping process, the whole +;;; changeover to the full object system is predicated on this. ;;; -;;; One important point is that the layout of standard classes and 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))) -(defun bootstrap-set-slot (type object slot-name new-value) - (setf (bootstrap-get-slot type object slot-name) new-value)) +;;; One important point is that the layout of standard classes and +;;; 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) + `(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)) (defun early-class-name (class) - (bootstrap-get-slot 'class class 'name)) + (!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))) (defun early-class-slotds (class) - (bootstrap-get-slot 'slot-class class 'slots)) + (!bootstrap-get-slot 'slot-class class 'slots)) (defun early-slot-definition-name (slotd) - (bootstrap-get-slot 'standard-effective-slot-definition slotd 'name)) + (!bootstrap-get-slot 'standard-effective-slot-definition slotd 'name)) (defun early-slot-definition-location (slotd) - (bootstrap-get-slot 'standard-effective-slot-definition slotd 'location)) + (!bootstrap-get-slot 'standard-effective-slot-definition slotd 'location)) (defun early-accessor-method-slot-name (method) - (bootstrap-get-slot 'standard-accessor-method method 'slot-name)) + (!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))) -;;; 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)) + (!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 (make-early-class-definition name - *load-truename* + *load-pathname* metaclass supers canonical-slots