Skip to content
Snippets Groups Projects
Commit 94577d17 authored by pw's avatar pw
Browse files

These changes remove some obsolete and unused type system interface codes,

and introduces code to "inform-type-system-about-std-class". The effect
of this new code is to put minimal class definitions into the compile-time
environment to prevent undefined-type warnings. These definitions are
replaced with the correct class defs at load-time.
parent 2c491d3c
No related branches found
No related tags found
No related merge requests found
......@@ -26,7 +26,7 @@
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.15 1999/05/30 23:13:52 pw Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.16 2000/08/03 16:58:55 pw Exp $")
;;;
;;; Bootstrapping the meta-braid.
;;;
......@@ -118,11 +118,6 @@
classes)))
(defun bootstrap-meta-braid ()
(let* ((name 'class)
(predicate-name (make-type-predicate-name name)))
(setf (gdefinition predicate-name)
#'(lambda (x) (declare (ignore x)) t))
(do-satisfies-deftype name predicate-name))
(let* ((*create-classes-from-internal-structure-definitions-p* nil)
std-class-wrapper std-class
standard-class-wrapper standard-class
......
......@@ -26,7 +26,7 @@
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.17 2000/07/01 22:03:03 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.18 2000/08/03 16:58:56 pw Exp $")
;;;
(in-package :pcl)
......@@ -160,7 +160,10 @@
(progn
(when (and (eq *boot-state* 'complete)
(not (member 'compile *defclass-times*)))
(inform-type-system-about-std-class name))
(when (eq metaclass 'standard-class)
;; a funcallable-standard-class metaclass here causes
;; a compiler crash in construct.lisp
(inform-type-system-about-std-class name)))
defclass-form)))))))
(defun make-initfunction (initform)
......
......@@ -70,7 +70,7 @@
;;;
;;; If symbol names a function which is traced or advised, redefine
;;; the `real' definition without affecting the advise.
;;;
;;
(defun (setf gdefinition) (new-definition name)
(c::%%defun name new-definition nil)
(c::note-name-defined name :function)
......@@ -181,22 +181,21 @@
(specializer-type (class-eq-specializer class)))
(defun inform-type-system-about-std-class (name)
(let ((predicate-name (make-type-predicate-name name)))
(setf (gdefinition predicate-name) (make-type-predicate name))
(do-satisfies-deftype name predicate-name)))
(defun make-type-predicate (name)
(let ((cell (find-class-cell name)))
#'(lambda (x)
(funcall (the function (find-class-cell-predicate cell)) x))))
;; This should only be called if metaclass is standard-class.
;; Compiler problems have been seen if the metaclass is
;; funcallable-standard-class and this is called from the defclass macro
;; expander. However, bootstrap-meta-braid calls this for funcallable-
;; standard-class metaclasses but *boot-state* is not 'complete then.
;;
;; The only effect of this code is to ensure a lisp:standard-class class
;; exists so as to avoid undefined-function compiler warnings. The
;; skeleton class will be replaced at load-time with the correct object.
;; Earlier revisions (<= 1.17) of this function were essentially NOOPs.
;This stuff isn't right. Good thing it isn't used.
;The satisfies predicate has to be a symbol. There is no way to
;construct such a symbol from a class object if class names change.
(defun class-predicate (class)
(when (symbolp class) (setq class (find-class class)))
#'(lambda (object) (memq class (class-precedence-list (class-of object)))))
(when (and (eq *boot-state* 'complete)
(null (lisp:find-class name nil)))
(setf (lisp:find-class name)
(lisp::make-standard-class :name name))))
(defun make-class-eq-predicate (class)
(when (symbolp class) (setq class (find-class class)))
......@@ -272,23 +271,6 @@
(t
(subtypep (convert-to-system-type type1)
(convert-to-system-type type2))))))))
(defun do-satisfies-deftype (name predicate)
(declare (ignore name predicate)))
(defun make-type-predicate-name (name &optional kind)
(if (symbol-package name)
(intern (format nil
"~@[~A ~]TYPE-PREDICATE ~A ~A"
kind
(package-name (symbol-package name))
(symbol-name name))
*the-pcl-package*)
(make-symbol (format nil
"~@[~A ~]TYPE-PREDICATE ~A"
kind
(symbol-name name)))))
(defvar *built-in-class-symbols* ())
......
......@@ -26,7 +26,7 @@
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.25 1999/05/30 23:14:08 pw Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.26 2000/08/03 16:58:56 pw Exp $")
;;;
(in-package :pcl)
......@@ -992,9 +992,8 @@
;;;; inform-type-system-about-class
;;;; make-type-predicate
;;;
;;; These are NOT part of the standard protocol. They are internal mechanism
;;; This is NOT part of the standard protocol. It is an internal mechanism
;;; which PCL uses to *try* and tell the type system about class definitions.
;;; In a more fully integrated implementation of CLOS, the type system would
;;; know about class objects and class names in a more fundamental way and
......@@ -1002,7 +1001,16 @@
;;; different.
;;;
(defmethod inform-type-system-about-class ((class std-class) name)
;; Maybe add skeleton lisp:standard-class to avoid undefined-function
;; compiler warnings. Not otherwise needed in this implementation.
(inform-type-system-about-std-class name))
(defmethod inform-type-system-about-class
((class funcallable-standard-class) name)
(declare (ignore name))
;; Avoid load-time warning of changing metaclass.
)
(defmethod compatible-meta-class-change-p (class proto-new-class)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment