Menu
▾
▴
[Sbcl-commits] master: Somewhat unify %COMPILER-{DEFCLASS, DEFINE-CONDITION}
|
From: Jan M. <sc...@us...> - 2016-10-15 15:25:01
|
The branch "master" has been updated in SBCL:
via 3fd690d309d58a94bcc7c4ebfe83168560bb909f (commit)
from 2a12bc6277dfffdc45494d2bd12af3fe86fb56ba (commit)
- Log -----------------------------------------------------------------
commit 3fd690d309d58a94bcc7c4ebfe83168560bb909f
Author: Jan Moringen <jmo...@te...>
Date: Wed Aug 5 07:13:17 2015 +0200
Somewhat unify %COMPILER-{DEFCLASS,DEFINE-CONDITION}
---
src/code/condition.lisp | 96 ++++++++++++++--------------
src/code/early-class.lisp | 156 ++++++++++++++++++++++++++++++++-------------
src/pcl/defclass.lisp | 67 ++++----------------
src/pcl/std-class.lisp | 19 +++---
4 files changed, 182 insertions(+), 156 deletions(-)
diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index 9a92357..30248ae 100644
--- a/src/code/condition.lisp
+++ b/src/code/condition.lisp
@@ -299,56 +299,56 @@
(defun %define-condition (name parent-types layout slots
direct-default-initargs all-readers all-writers
source-location &optional documentation)
- (with-single-package-locked-error
- (:symbol name "defining ~A as a condition")
- (%compiler-define-condition name parent-types layout all-readers all-writers)
- (when source-location
- (setf (layout-source-location layout) source-location))
- (let ((class (find-classoid name))) ; FIXME: rename to 'classoid'
- (setf (condition-classoid-slots class) slots
- (condition-classoid-direct-default-initargs class) direct-default-initargs
- (fdocumentation name 'type) documentation)
+ (call-with-defining-class
+ 'condition name
+ (lambda ()
+ (%%compiler-define-condition name parent-types layout all-readers all-writers)
+ (when source-location
+ (setf (layout-source-location layout) source-location))
+ (let ((classoid (find-classoid name)))
+ (setf (condition-classoid-slots classoid) slots
+ (condition-classoid-direct-default-initargs classoid) direct-default-initargs
+ (fdocumentation name 'type) documentation)
- (dolist (slot slots)
+ (dolist (slot slots)
+ ;; Set up reader and writer functions.
+ (let ((slot-name (condition-slot-name slot)))
+ (dolist (reader (condition-slot-readers slot))
+ (install-condition-slot-reader reader name slot-name))
+ (dolist (writer (condition-slot-writers slot))
+ (install-condition-slot-writer writer name slot-name))))
- ;; Set up reader and writer functions.
- (let ((slot-name (condition-slot-name slot)))
- (dolist (reader (condition-slot-readers slot))
- (install-condition-slot-reader reader name slot-name))
- (dolist (writer (condition-slot-writers slot))
- (install-condition-slot-writer writer name slot-name))))
-
- ;; Compute effective slots and set up the class and hairy slots
- ;; (subsets of the effective slots.)
- (setf (condition-classoid-class-slots class) '()
- (condition-classoid-hairy-slots class) '())
- (let ((eslots (compute-effective-slots class))
- (e-def-initargs
- (reduce #'append
- (mapcar #'condition-classoid-direct-default-initargs
- (condition-classoid-cpl class)))))
- (dolist (slot eslots)
- (ecase (condition-slot-allocation slot)
- (:class
- (unless (condition-slot-cell slot)
- (setf (condition-slot-cell slot)
- (list (if (condition-slot-initform-p slot)
- (let ((initfun (condition-slot-initfunction slot)))
- (aver (functionp initfun))
- (funcall initfun))
- *empty-condition-slot*))))
- (push slot (condition-classoid-class-slots class)))
- ((:instance nil)
- (setf (condition-slot-allocation slot) :instance)
- ;; FIXME: isn't this "always hairy"?
- (when (or (functionp (condition-slot-initfunction slot))
- (dolist (initarg (condition-slot-initargs slot) nil)
- (when (functionp (third (assoc initarg e-def-initargs)))
- (return t))))
- (push slot (condition-classoid-hairy-slots class)))))))
- (dolist (fun *define-condition-hooks*)
- (funcall fun class)))
- name))
+ ;; Compute effective slots and set up the class and hairy slots
+ ;; (subsets of the effective slots.)
+ (setf (condition-classoid-class-slots classoid) '()
+ (condition-classoid-hairy-slots classoid) '())
+ (let ((eslots (compute-effective-slots classoid))
+ (e-def-initargs
+ (reduce #'append
+ (mapcar #'condition-classoid-direct-default-initargs
+ (condition-classoid-cpl classoid)))))
+ (dolist (slot eslots)
+ (ecase (condition-slot-allocation slot)
+ (:class
+ (unless (condition-slot-cell slot)
+ (setf (condition-slot-cell slot)
+ (list (if (condition-slot-initform-p slot)
+ (let ((initfun (condition-slot-initfunction slot)))
+ (aver (functionp initfun))
+ (funcall initfun))
+ *empty-condition-slot*))))
+ (push slot (condition-classoid-class-slots classoid)))
+ ((:instance nil)
+ (setf (condition-slot-allocation slot) :instance)
+ ;; FIXME: isn't this "always hairy"?
+ (when (or (functionp (condition-slot-initfunction slot))
+ (dolist (initarg (condition-slot-initargs slot) nil)
+ (when (functionp (third (assoc initarg e-def-initargs)))
+ (return t))))
+ (push slot (condition-classoid-hairy-slots classoid)))))))
+ (dolist (fun *define-condition-hooks*)
+ (funcall fun classoid)))))
+ name)
(defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
&body options)
diff --git a/src/code/early-class.lisp b/src/code/early-class.lisp
index 7e750ae..92f46d0 100644
--- a/src/code/early-class.lisp
+++ b/src/code/early-class.lisp
@@ -11,58 +11,124 @@
(in-package "SB!KERNEL")
+(defun call-with-defining-class (kind name thunk)
+ (declare (ignorable kind name))
+ (with-single-package-locked-error
+ (:symbol name "defining ~S as a ~(~A~)" kind)
+ (funcall thunk)))
+
+(defun preinform-compiler-about-class-type (name forthcoming-info)
+ ;; 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)
+ (when (and forthcoming-info (not (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)))
+
+(symbol-macrolet
+ ((reader-function-type (specifier-type '(function (t) t)))
+ (writer-function-type (specifier-type '(function (t t) t))))
+ (flet ((proclaim-ftype-for-name (kind name type)
+ (ecase kind
+ (condition
+ (sb!xc:proclaim `(ftype ,(type-specifier type) ,name)))
+ (class
+ (when (eq (info :function :where-from name) :assumed)
+ (sb!c:proclaim-ftype name type nil :defined))))))
+
+ (defun preinform-compiler-about-accessors (kind readers writers)
+ (flet ((inform (names type)
+ (mapc (lambda (name) (proclaim-ftype-for-name kind name type))
+ names)))
+ (inform readers reader-function-type)
+ (inform writers writer-function-type)))
+
+ (defun preinform-compiler-about-slot-functions (kind slots)
+ (flet ((inform (slots key type)
+ (mapc (lambda (slot)
+ (let ((name (funcall key slot)))
+ (proclaim-ftype-for-name kind name type)))
+ slots)))
+ (inform slots #'sb!pcl::slot-reader-name reader-function-type)
+ (inform slots #'sb!pcl::slot-boundp-name reader-function-type)
+ (inform slots #'sb!pcl::slot-writer-name writer-function-type)))))
+
+(defun %%compiler-defclass (name readers writers slots)
+ ;; 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."
+ (preinform-compiler-about-class-type name t)
+ (preinform-compiler-about-accessors 'class readers writers)
+ (preinform-compiler-about-slot-functions 'class slots))
+
+(defun %compiler-defclass (name readers writers slots)
+ (call-with-defining-class
+ 'class name
+ (lambda ()
+ (%%compiler-defclass name readers writers slots))))
+
;;; This used to be in an (EVAL-WHEN (:COMPILE-TOPLEVEL ...))
;;; which no longer works, because at run-the-xc-time the
;;; WITH-SINGLE-PACKAGE-LOCKED-ERROR macro doesn't work yet,
;;; so just use the definition that was loaded from the fasl
;;; when the cross-compiler was compiled.
-(defun %compiler-define-condition (name direct-supers layout
- all-readers all-writers)
+(defun %%compiler-define-condition (name direct-supers layout readers writers)
(declare (notinline find-classoid))
- (with-single-package-locked-error
- (:symbol name "defining ~A as a condition")
- (sb!xc:proclaim `(ftype (function (t) t) ,@all-readers))
- (sb!xc:proclaim `(ftype (function (t t) t) ,@all-writers))
- (multiple-value-bind (class old-layout)
- (insured-find-classoid name
- #'condition-classoid-p
- #'make-condition-classoid)
- (setf (layout-classoid layout) class)
- (setf (classoid-direct-superclasses class)
- (mapcar #'find-classoid direct-supers))
- (cond ((not old-layout)
- (register-layout layout))
- ((not *type-system-initialized*)
- (setf (layout-classoid old-layout) class)
- (setq layout old-layout)
- (unless (eq (classoid-layout class) layout)
- (register-layout layout)))
- ((redefine-layout-warning "current"
- old-layout
- "new"
- (layout-length layout)
- (layout-inherits layout)
- (layout-depthoid layout)
- (layout-bitmap layout))
- (register-layout layout :invalidate t))
- ((not (classoid-layout class))
+ (preinform-compiler-about-class-type name nil)
+ (preinform-compiler-about-accessors 'condition readers writers)
+ (multiple-value-bind (class old-layout)
+ (insured-find-classoid name
+ #'condition-classoid-p
+ #'make-condition-classoid)
+ (setf (layout-classoid layout) class)
+ (setf (classoid-direct-superclasses class)
+ (mapcar #'find-classoid direct-supers))
+ (cond ((not old-layout)
+ (register-layout layout))
+ ((not *type-system-initialized*)
+ (setf (layout-classoid old-layout) class)
+ (setq layout old-layout)
+ (unless (eq (classoid-layout class) layout)
(register-layout layout)))
+ ((redefine-layout-warning "current"
+ old-layout
+ "new"
+ (layout-length layout)
+ (layout-inherits layout)
+ (layout-depthoid layout)
+ (layout-bitmap layout))
+ (register-layout layout :invalidate t))
+ ((not (classoid-layout class))
+ (register-layout layout)))
- ;; This looks totally bogus - it essentially means that the LAYOUT-INFO
- ;; of a condition is good for nothing, because it describes something
- ;; that is not the condition class being defined.
- ;; In addition to which, the INFO for CONDITION itself describes
- ;; slots which do not exist, viz:
- ;; (dd-slots (layout-info (classoid-layout (find-classoid 'condition))))
- ;; => (#<DEFSTRUCT-SLOT-DESCRIPTION ACTUAL-INITARGS>
- ;; #<DEFSTRUCT-SLOT-DESCRIPTION ASSIGNED-SLOTS>)
- (setf (layout-info layout)
- (layout-info (classoid-layout (find-classoid 'condition))))
+ ;; This looks totally bogus - it essentially means that the LAYOUT-INFO
+ ;; of a condition is good for nothing, because it describes something
+ ;; that is not the condition class being defined.
+ ;; In addition to which, the INFO for CONDITION itself describes
+ ;; slots which do not exist, viz:
+ ;; (dd-slots (layout-info (classoid-layout (find-classoid 'condition))))
+ ;; => (#<DEFSTRUCT-SLOT-DESCRIPTION ACTUAL-INITARGS>
+ ;; #<DEFSTRUCT-SLOT-DESCRIPTION ASSIGNED-SLOTS>)
+ (setf (layout-info layout)
+ (layout-info (classoid-layout (find-classoid 'condition))))
- (setf (find-classoid name) class)
+ (setf (find-classoid name) class)
- ;; Initialize CPL slot.
- (setf (condition-classoid-cpl class)
- (remove-if-not #'condition-classoid-p
- (std-compute-class-precedence-list class)))))
- (values))
+ ;; Initialize CPL slot.
+ (setf (condition-classoid-cpl class)
+ (remove-if-not #'condition-classoid-p
+ (std-compute-class-precedence-list class)))))
+
+(defun %compiler-define-condition (name direct-supers layout readers writers)
+ (call-with-defining-class
+ 'condition name
+ (lambda ()
+ (%%compiler-define-condition name direct-supers layout readers writers))))
diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp
index f91aa8d..d7e3922 100644
--- a/src/pcl/defclass.lisp
+++ b/src/pcl/defclass.lisp
@@ -117,10 +117,11 @@
;; 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
- ',*readers-for-this-defclass*
- ',*writers-for-this-defclass*
- ',*slot-names-for-this-defclass*))
+ (sb-kernel::%compiler-defclass
+ ',name
+ ',*readers-for-this-defclass*
+ ',*writers-for-this-defclass*
+ ',*slot-names-for-this-defclass*))
,defclass-form)))))))
(defun canonize-defclass-options (class-name options)
@@ -294,44 +295,6 @@
(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
- ;; "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."
- (preinform-compiler-about-class-type name)
- (preinform-compiler-about-accessors readers writers slots))
-
-(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)
- (with-single-package-locked-error (:symbol name "proclaiming ~S as a class"))
- (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))
-
-(defun preinform-compiler-about-accessors (readers writers slots)
- (flet ((inform (names type &key key)
- (mapc (lambda (name)
- (let ((name (if key (funcall key name) name)))
- (when (eq (info :function :where-from name) :assumed)
- (sb-c:proclaim-ftype name type nil :defined))))
- names)))
- (let ((rtype (specifier-type '(function (t) t)))
- (wtype (specifier-type '(function (t t) t))))
- (inform readers rtype)
- (inform writers wtype)
- (inform slots rtype :key #'slot-reader-name)
- (inform slots rtype :key #'slot-boundp-name)
- (inform slots wtype :key #'slot-writer-name))))
;;; This is the early definition of LOAD-DEFCLASS. It just collects up
;;; all the class definitions in a list. Later, in braid1.lisp, these
@@ -487,19 +450,15 @@
;; 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))
- (let ((ecd
- (make-early-class-definition name
- source-location
- metaclass
- supers
- canonical-slots
- canonical-options))
+ (sb-kernel::%%compiler-defclass name readers writers slot-names)
+ (let ((ecd (make-early-class-definition name
+ source-location
+ metaclass
+ (copy-tree supers)
+ (copy-tree canonical-slots)
+ (copy-tree canonical-options)))
(existing
- (find name *early-class-definitions* :key #'ecd-class-name)))
+ (find name *early-class-definitions* :key #'ecd-class-name)))
(setq *early-class-definitions*
(cons ecd (remove existing *early-class-definitions*)))
ecd))
diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 1070b8c..3d9353a 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -326,15 +326,16 @@
(defun real-load-defclass (name metaclass-name supers slots other
readers writers slot-names source-location &optional safe-p)
- (with-single-package-locked-error (:symbol name "defining ~S as a class")
- (%compiler-defclass name readers writers slot-names)
- (let ((res (apply #'ensure-class name :metaclass metaclass-name
- :direct-superclasses supers
- :direct-slots slots
- :definition-source source-location
- 'safe-p safe-p
- other)))
- res)))
+ (sb-kernel::call-with-defining-class
+ 'class name
+ (lambda ()
+ (sb-kernel::%%compiler-defclass name readers writers slot-names)
+ (apply #'ensure-class name :metaclass metaclass-name
+ :direct-superclasses supers
+ :direct-slots slots
+ :definition-source source-location
+ 'safe-p safe-p
+ other))))
(setf (gdefinition 'load-defclass) #'real-load-defclass)
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|