X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefclass.lisp;h=09bf800ef4b0dc2ec38cb42aa595cb93709465f6;hb=b171183c7115b865b00662ff346061ecd5291ce4;hp=2db78e6993dc0a13b30dfb0e176ffeddb038391e;hpb=2f1b1aa900279de818d450935f472684e728d54d;p=sbcl.git diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 2db78e6..09bf800 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -59,7 +59,7 @@ ;;; 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) +(defmacro defclass (&environment env name %direct-superclasses %direct-slots &rest %options) (let ((supers (copy-tree %direct-superclasses)) (slots (copy-tree %direct-slots)) (options (copy-tree %options))) @@ -72,11 +72,7 @@ (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)))) @@ -86,7 +82,7 @@ (*slot-names-for-this-defclass* ())) (let ((canonical-slots (mapcar (lambda (spec) - (canonicalize-slot-specification name spec)) + (canonicalize-slot-specification name spec env)) slots)) (other-initargs (mapcar (lambda (option) @@ -102,29 +98,20 @@ 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-symbol x) - ,(slot-boundp-symbol x)) - (ftype (function (t t) t) - ,(slot-writer-symbol 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))))))) + `(progn + (let ,(mapcar #'cdr *initfunctions-for-this-defclass*) + (%compiler-defclass ',name + ',*readers-for-this-defclass* + ',*writers-for-this-defclass* + ',*slot-names-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 @@ -144,7 +131,8 @@ (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))) + name (class-direct-slots (find-class name)) + include))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) ,defstruct-form) ; really compile the defstruct-form @@ -162,8 +150,22 @@ ;; 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)))))))) + (%compiler-defclass ',name + ',*readers-for-this-defclass* + ',*writers-for-this-defclass* + ',*slot-names-for-this-defclass*)) + (eval-when (:load-toplevel :execute) + ,defclass-form))))))))) + +(defun %compiler-defclass (name readers writers slot-names) + (with-single-package-locked-error (:symbol name "defining ~A as a class") + (preinform-compiler-about-class-type name) + (proclaim `(ftype (function (t) t) + ,@readers + ,@(mapcar #'slot-reader-name slot-names) + ,@(mapcar #'slot-boundp-name slot-names))) + (proclaim `(ftype (function (t t) t) + ,@writers ,@(mapcar #'slot-writer-name slot-names))))) (defun make-initfunction (initform) (cond ((or (eq initform t) @@ -185,52 +187,72 @@ (push entry *initfunctions-for-this-defclass*)) (cadr entry))))) -(defun canonicalize-slot-specification (class-name spec) - (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*) +(defun canonicalize-slot-specification (class-name spec env) + (labels ((slot-name-illegal (reason) + (error 'simple-program-error + :format-control + (format nil "~~@" reason) + :format-arguments (list class-name spec))) + (check-slot-name-legality (name) + (cond + ((not (symbolp name)) + (slot-name-illegal "not a symbol")) + ((keywordp name) + (slot-name-illegal "a keyword")) + ((constantp name env) + (slot-name-illegal "a constant"))))) + (cond ((atom spec) + (check-slot-name-legality spec) + (push spec *slot-names-for-this-defclass*) + `'(:name ,spec)) + ((null (cdr spec)) + (check-slot-name-legality (car 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.~%~ - Convert it to ~S" - class-name spec (list (car spec) :initform (cadr spec)))) - (t - (let* ((name (pop spec)) - (readers ()) - (writers ()) - (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 readers) - (push `(setf ,val) writers)) - (:reader (push val readers)) - (:writer (push val writers)) - (:initarg (push val initargs)))) - (loop (unless (remf spec :accessor) (return))) - (loop (unless (remf spec :reader) (return))) - (loop (unless (remf spec :writer) (return))) - (loop (unless (remf spec :initarg) (return))) - (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 - :initargs ',initargs - ',spec)) - (if (eq initform unsupplied) - `(list* ,@spec) - `(list* :initfunction ,(make-initfunction initform) ,@spec)))))) + ((null (cddr spec)) + (error 'simple-program-error + :format-control + "~@" + :format-arguments + (list class-name spec + `(,(car spec) :initform ,(cadr spec))))) + (t + (let* ((name (car spec)) + (spec (cdr spec)) + (readers ()) + (writers ()) + (initargs ()) + (unsupplied (list nil)) + (initform (getf spec :initform unsupplied))) + (check-slot-name-legality name) + (push name *slot-names-for-this-defclass*) + (doplist (key val) spec + (case key + (:accessor (push val readers) + (push `(setf ,val) writers)) + (:reader (push val readers)) + (:writer (push val writers)) + (:initarg (push val initargs)))) + (loop (unless (remf spec :accessor) (return))) + (loop (unless (remf spec :reader) (return))) + (loop (unless (remf spec :writer) (return))) + (loop (unless (remf spec :initarg) (return))) + (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 + :initargs ',initargs + ',spec)) + (if (eq initform unsupplied) + `(list* ,@spec) + `(list* :initfunction ,(make-initfunction initform) + ,@spec))))))) (defun canonicalize-defclass-option (class-name option) (declare (ignore class-name))