"%OTHER-POINTER-P"
"STANDARD-CLASSOID" "CLASSOID-OF"
- "MAKE-STANDARD-CLASSOID" "CLASSOID-CELL-TYPEP"
+ "MAKE-STANDARD-CLASSOID"
+ "CLASSOID-CELL-CLASSOID"
+ "CLASSOID-CELL-NAME"
+ "CLASSOID-CELL-PCL-CLASS"
+ "CLASSOID-CELL-TYPEP"
+ "CLEAR-CLASSOID"
"FIND-CLASSOID-CELL" "EXTRACT-FUN-TYPE"
"%RANDOM-DOUBLE-FLOAT"
#!+long-float "%RANDOM-LONG-FLOAT"
"%RANDOM-SINGLE-FLOAT" "STATIC-CLASSOID"
"%FUNCALLABLE-INSTANCE-INFO" "RANDOM-CHUNK" "BIG-RANDOM-CHUNK"
- "LAYOUT-CLOS-HASH-LIMIT" "CLASSOID-CELL-NAME"
+ "LAYOUT-CLOS-HASH-LIMIT"
"BUILT-IN-CLASSOID-DIRECT-SUPERCLASSES"
"BUILT-IN-CLASSOID-TRANSLATION" "RANDOM-LAYOUT-CLOS-HASH"
"CLASSOID-PCL-CLASS" "FUNCALLABLE-STRUCTURE"
"FUNCALLABLE-INSTANCE-FUN" "%FUNCALLABLE-INSTANCE-LAYOUT"
"%SET-FUNCALLABLE-INSTANCE-LAYOUT"
- "BASIC-STRUCTURE-CLASSOID" "CLASSOID-CELL-CLASSOID"
+ "BASIC-STRUCTURE-CLASSOID"
"REGISTER-LAYOUT"
"FUNCALLABLE-INSTANCE" "RANDOM-FIXNUM-MAX"
"MAKE-STATIC-CLASSOID" "INSTANCE-LAMBDA"
(/primitive-print (symbol-name name))
(when trans-p
(/show0 "in TRANS-P case")
- (let ((classoid (classoid-cell-classoid (find-classoid-cell name)))
+ (let ((classoid (classoid-cell-classoid (find-classoid-cell name :create t)))
(type (specifier-type translation)))
(setf (built-in-classoid-translation classoid) type)
(setf (info :type :builtin name) type)))))
;;; cold-load time.
(defvar *forward-referenced-layouts*)
(!cold-init-forms
- (setq *forward-referenced-layouts* (make-hash-table :test 'equal
- #-sb-xc-host #-sb-xc-host
- :synchronized t))
+ (setq *forward-referenced-layouts* (make-hash-table :test 'equal))
#-sb-xc-host (progn
(/show0 "processing *!INITIAL-LAYOUTS*")
(dolist (x *!initial-layouts*)
;;; cross-compilability reasons (i.e. convenience of using this
;;; function in a MAKE-LOAD-FORM expression) that functionality has
;;; been split off into INIT-OR-CHECK-LAYOUT.
-(declaim (ftype (function (symbol) layout) find-layout))
+(declaim (ftype (sfunction (symbol) layout) find-layout))
(defun find-layout (name)
- (let ((classoid (find-classoid name nil)))
- (or (and classoid (classoid-layout classoid))
- (gethash name *forward-referenced-layouts*)
- (setf (gethash name *forward-referenced-layouts*)
- (make-layout :classoid (or classoid
- (make-undefined-classoid name)))))))
+ ;; This seems to be currently used only from the compiler, but make
+ ;; it thread-safe all the same. We need to lock *F-R-L* before doing
+ ;; FIND-CLASSOID in case (SETF FIND-CLASSOID) happens in parallel.
+ (let ((table *forward-referenced-layouts*))
+ (with-locked-hash-table (table)
+ (let ((classoid (find-classoid name nil)))
+ (or (and classoid (classoid-layout classoid))
+ (gethash name table)
+ (setf (gethash name table)
+ (make-layout :classoid (or classoid (make-undefined-classoid name)))))))))
;;; If LAYOUT is uninitialized, initialize it with CLASSOID, LENGTH,
;;; INHERITS, and DEPTHOID, otherwise require that it be consistent
(:constructor make-classoid-cell (name &optional classoid))
(:make-load-form-fun (lambda (c)
`(find-classoid-cell
- ',(classoid-cell-name c))))
+ ',(classoid-cell-name c)
+ :errorp t)))
#-no-ansi-print-object
(:print-object (lambda (s stream)
(print-unreadable-object (s stream :type t)
(prin1 (classoid-cell-name s) stream)))))
;; Name of class we expect to find.
(name nil :type symbol :read-only t)
- ;; Class or NIL if not yet defined.
- (classoid nil :type (or classoid null)))
-(defun find-classoid-cell (name)
- (or (info :type :classoid name)
- (setf (info :type :classoid name)
- (make-classoid-cell name))))
+ ;; Classoid or NIL if not yet defined.
+ (classoid nil :type (or classoid null))
+ ;; PCL class, if any
+ (pcl-class nil))
+
+(defvar *classoid-cells*)
+(!cold-init-forms
+ (setq *classoid-cells* (make-hash-table :test 'eq)))
+
+(defun find-classoid-cell (name &key create errorp)
+ (let ((table *classoid-cells*)
+ (real-name (uncross name)))
+ (or (with-locked-hash-table (table)
+ (or (gethash real-name table)
+ (when create
+ (setf (gethash real-name table) (make-classoid-cell real-name)))))
+ (when errorp
+ (error 'simple-type-error
+ :datum nil
+ :expected-type 'class
+ :format-control "Class not yet defined: ~S"
+ :format-arguments (list name))))))
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
-(defun find-classoid (name &optional (errorp t) environment)
- #!+sb-doc
- "Return the class with the specified NAME. If ERRORP is false, then
-NIL is returned when no such class exists."
- (declare (type symbol name) (ignore environment))
- (let ((res (classoid-cell-classoid (find-classoid-cell name))))
- (if (or res (not errorp))
- res
- (error 'simple-type-error
- :datum nil
- :expected-type 'class
- :format-control "class not yet defined:~% ~S"
- :format-arguments (list name)))))
-(defun (setf find-classoid) (new-value name)
- #-sb-xc (declare (type (or null classoid) new-value))
- (cond
- ((null new-value)
- (ecase (info :type :kind name)
- ((nil))
- (:defined)
- (:primitive
- (error "attempt to redefine :PRIMITIVE type: ~S" name))
- ((:forthcoming-defclass-type :instance)
- (setf (info :type :kind name) nil
- (info :type :classoid name) nil
- (info :type :documentation name) nil
- (info :type :compiler-layout name) nil))))
- (t
- (ecase (info :type :kind name)
- ((nil))
- (:forthcoming-defclass-type
- ;; XXX Currently, nothing needs to be done in this
- ;; case. Later, when PCL is integrated tighter into SBCL, this
- ;; might need more work.
- nil)
- (:instance
- ;; KLUDGE: The reason these clauses aren't directly parallel
- ;; is that we need to use the internal CLASSOID structure
- ;; ourselves, because we don't have CLASSes to work with until
- ;; PCL is built. In the host, CLASSes have an approximately
- ;; one-to-one correspondence with the target CLASSOIDs (as
- ;; well as with the target CLASSes, modulo potential
- ;; differences with respect to conditions).
- #+sb-xc-host
- (let ((old (class-of (find-classoid name)))
- (new (class-of new-value)))
- (unless (eq old new)
- (bug "trying to change the metaclass of ~S from ~S to ~S in the ~
- cross-compiler."
- name (class-name old) (class-name new))))
- #-sb-xc-host
- (let ((old (classoid-of (find-classoid name)))
- (new (classoid-of new-value)))
- (unless (eq old new)
- (warn "changing meta-class of ~S from ~S to ~S"
- name (classoid-name old) (classoid-name new)))))
- (:primitive
- (error "illegal to redefine standard type ~S" name))
- (:defined
- (warn "redefining DEFTYPE type to be a class: ~S" name)
- (setf (info :type :expander name) nil)))
-
- (remhash name *forward-referenced-layouts*)
- (%note-type-defined name)
- ;; we need to handle things like
- ;; (setf (find-class 'foo) (find-class 'integer))
- ;; and
- ;; (setf (find-class 'integer) (find-class 'integer))
- (cond
- ((built-in-classoid-p new-value)
- (setf (info :type :kind name) (or (info :type :kind name) :defined))
- (let ((translation (built-in-classoid-translation new-value)))
- (when translation
- (setf (info :type :translator name)
- (lambda (c) (declare (ignore c)) translation)))))
- (t (setf (info :type :kind name) :instance)))
- (setf (classoid-cell-classoid (find-classoid-cell name)) new-value)
- (unless (eq (info :type :compiler-layout name)
- (classoid-layout new-value))
- (setf (info :type :compiler-layout name) (classoid-layout new-value)))))
- new-value)
-) ; EVAL-WHEN
+
+ ;; Return the classoid with the specified NAME. If ERRORP is false,
+ ;; then NIL is returned when no such class exists."
+ (defun find-classoid (name &optional (errorp t))
+ (declare (type symbol name))
+ (let ((cell (find-classoid-cell name :errorp errorp)))
+ (when cell (classoid-cell-classoid cell))))
+
+ ;; This is definitely not thread safe with itself -- but should be
+ ;; OK with parallel FIND-CLASSOID & FIND-LAYOUT.
+ (defun (setf find-classoid) (new-value name)
+ #-sb-xc (declare (type (or null classoid) new-value))
+ (aver new-value)
+ (let ((table *forward-referenced-layouts*))
+ (with-locked-hash-table (table)
+ (let ((cell (find-classoid-cell name :create t)))
+ (ecase (info :type :kind name)
+ ((nil))
+ (:forthcoming-defclass-type
+ ;; FIXME: Currently, nothing needs to be done in this case.
+ ;; Later, when PCL is integrated tighter into SBCL, this
+ ;; might need more work.
+ nil)
+ (:instance
+ (aver cell)
+ (let ((old-value (classoid-cell-classoid cell)))
+ (aver old-value)
+ ;; KLUDGE: The reason these clauses aren't directly
+ ;; parallel is that we need to use the internal
+ ;; CLASSOID structure ourselves, because we don't
+ ;; have CLASSes to work with until PCL is built. In
+ ;; the host, CLASSes have an approximately
+ ;; one-to-one correspondence with the target
+ ;; CLASSOIDs (as well as with the target CLASSes,
+ ;; modulo potential differences with respect to
+ ;; conditions).
+ #+sb-xc-host
+ (let ((old (class-of old-value))
+ (new (class-of new-value)))
+ (unless (eq old new)
+ (bug "Trying to change the metaclass of ~S from ~S to ~S in the ~
+ cross-compiler."
+ name (class-name old) (class-name new))))
+ #-sb-xc-host
+ (let ((old (classoid-of old-value))
+ (new (classoid-of new-value)))
+ (unless (eq old new)
+ (warn "Changing meta-class of ~S from ~S to ~S."
+ name (classoid-name old) (classoid-name new))))))
+ (:primitive
+ (error "Cannot redefine standard type ~S." name))
+ (:defined
+ (warn "Redefining DEFTYPE type to be a class: ~S" name)
+ (setf (info :type :expander name) nil)))
+
+ (remhash name table)
+ (%note-type-defined name)
+ ;; we need to handle things like
+ ;; (setf (find-class 'foo) (find-class 'integer))
+ ;; and
+ ;; (setf (find-class 'integer) (find-class 'integer))
+ (cond ((built-in-classoid-p new-value)
+ (setf (info :type :kind name)
+ (or (info :type :kind name) :defined))
+ (let ((translation (built-in-classoid-translation new-value)))
+ (when translation
+ (setf (info :type :translator name)
+ (lambda (c) (declare (ignore c)) translation)))))
+ (t
+ (setf (info :type :kind name) :instance)))
+ (setf (classoid-cell-classoid cell) new-value)
+ (unless (eq (info :type :compiler-layout name)
+ (classoid-layout new-value))
+ (setf (info :type :compiler-layout name)
+ (classoid-layout new-value))))))
+ new-value)
+
+ (defun clear-classoid (name cell)
+ (ecase (info :type :kind name)
+ ((nil))
+ (:defined)
+ (:primitive
+ (error "Attempt to remove :PRIMITIVE type: ~S" name))
+ ((:forthcoming-defclass-type :instance)
+ (when cell
+ ;; Note: We cannot remove the classoid cell from the table,
+ ;; since compiled code may refer directly to the cell, and
+ ;; getting a different cell for a classoid with the same name
+ ;; just would not do.
+
+ ;; Remove the proper name of the classoid.
+ (setf (classoid-name (classoid-cell-classoid cell)) nil)
+ ;; Clear the cell.
+ (setf (classoid-cell-classoid cell) nil
+ (classoid-cell-pcl-class cell) nil))
+ (setf (info :type :kind name) nil
+ (info :type :documentation name) nil
+ (info :type :compiler-layout name) nil)))))
;;; Called when we are about to define NAME as a class meeting some
;;; predicate (such as a meta-class type test.) The first result is
;;; always of the desired class. The second result is any existing
;;; LAYOUT for this name.
+;;;
+;;; Again, this should be compiler-only, but easier to make this
+;;; thread-safe.
(defun insured-find-classoid (name predicate constructor)
(declare (type function predicate constructor))
- (let* ((old (find-classoid name nil))
- (res (if (and old (funcall predicate old))
- old
- (funcall constructor :name name)))
- (found (or (gethash name *forward-referenced-layouts*)
- (when old (classoid-layout old)))))
- (when found
- (setf (layout-classoid found) res))
- (values res found)))
-
-;;; If the class has a proper name, return the name, otherwise return
-;;; the class.
-(defun classoid-proper-name (class)
- #-sb-xc (declare (type classoid class))
- (let ((name (classoid-name class)))
- (if (and name (eq (find-classoid name nil) class))
+ (let ((table *forward-referenced-layouts*))
+ (with-locked-hash-table (table)
+ (let* ((old (find-classoid name nil))
+ (res (if (and old (funcall predicate old))
+ old
+ (funcall constructor :name name)))
+ (found (or (gethash name table)
+ (when old (classoid-layout old)))))
+ (when found
+ (setf (layout-classoid found) res))
+ (values res found)))))
+
+;;; If the classoid has a proper name, return the name, otherwise return
+;;; the classoid.
+(defun classoid-proper-name (classoid)
+ #-sb-xc (declare (type classoid classoid))
+ (let ((name (classoid-name classoid)))
+ (if (and name (eq (find-classoid name nil) classoid))
name
- class)))
+ classoid)))
\f
;;;; CLASS type operations
nil
(mapcar #'find-classoid direct-superclasses)))))
(setf (info :type :kind name) #+sb-xc-host :defined #-sb-xc-host :primitive
- (classoid-cell-classoid (find-classoid-cell name)) classoid)
+ (classoid-cell-classoid (find-classoid-cell name :create t)) classoid)
(unless trans-p
(setf (info :type :builtin name) classoid))
(let* ((inherits-vector
(let* ((name (first x))
(inherits-list (second x))
(classoid (make-standard-classoid :name name))
- (classoid-cell (find-classoid-cell name)))
+ (classoid-cell (find-classoid-cell name :create t)))
;; Needed to open-code the MAP, below
(declare (type list inherits-list))
(setf (classoid-cell-classoid classoid-cell) classoid
- (info :type :classoid name) classoid-cell
(info :type :kind name) :instance)
(let ((inherits (map 'simple-vector
(lambda (x)
((eq (classoid-layout class) layout)
(remhash name *forward-referenced-layouts*))
(t
- ;; FIXME: ERROR?
- (warn "something strange with forward layout for ~S:~% ~S"
- name
- layout))))))
+ (error "Something strange with forward layout for ~S:~% ~S"
+ name layout))))))
(!cold-init-forms
#-sb-xc-host (/show0 "about to set *BUILT-IN-CLASS-CODES*")
(error "Class is not a structure class: ~S" ',name))
,layout))))))
-;;; Get layout right away.
-(sb!xc:defmacro compile-time-find-layout (name)
- (find-layout name))
-
;;; re. %DELAYED-GET-COMPILER-LAYOUT and COMPILE-TIME-FIND-LAYOUT, above..
;;;
;;; FIXME: Perhaps both should be defined with DEFMACRO-MUNDANELY?
(:instance
(warn "The class ~S is being redefined to be a DEFTYPE." name)
(undefine-structure (layout-info (classoid-layout (find-classoid name))))
- (setf (classoid-cell-classoid (find-classoid-cell name)) nil)
+ (setf (classoid-cell-classoid (find-classoid-cell name :create t)) nil)
(setf (info :type :compiler-layout name) nil)
(setf (info :type :kind name) :defined))
(:defined
(sb!xc:deftype name-for-class () t)
(defknown classoid-name (classoid) name-for-class (flushable))
-(defknown find-classoid (name-for-class &optional t lexenv-designator)
+(defknown find-classoid (name-for-class &optional t)
(or classoid null) ())
(defknown classoid-of (t) classoid (flushable))
(defknown layout-of (t) layout (flushable))
:type-spec (or ctype null)
:default nil)
-;;; If this is a class name, then the value is a cons (NAME . CLASS),
-;;; where CLASS may be null if the class hasn't been defined yet. Note
-;;; that for built-in classes, the kind may be :PRIMITIVE and not
-;;; :INSTANCE. The name is in the cons so that we can signal a
-;;; meaningful error if we only have the cons.
-(define-info-type
- :class :type
- :type :classoid
- :type-spec (or sb!kernel::classoid-cell null)
- :default nil)
-
;;; layout for this type being used by the compiler
(define-info-type
:class :type
(aver ctype)
(ir1-transform-type-predicate object ctype)))
-;;; If FIND-CLASS is called on a constant class, locate the CLASS-CELL
-;;; at load time.
+;;; If FIND-CLASSOID is called on a constant class, locate the
+;;; CLASSOID-CELL at load time.
(deftransform find-classoid ((name) ((constant-arg symbol)) *)
(let* ((name (lvar-value name))
- (cell (find-classoid-cell name)))
+ (cell (find-classoid-cell name :create t)))
`(or (classoid-cell-classoid ',cell)
(error "class not yet defined: ~S" name))))
\f
(/noshow "default case -- ,PRED and CLASS-CELL-TYPEP")
`(and (,pred object)
(classoid-cell-typep (,get-layout object)
- ',(find-classoid-cell name)
+ ',(find-classoid-cell name :create t)
object)))))))))
;;; If the specifier argument is a quoted constant, then we consider
(defun eval-form (form)
(lambda () (eval form)))
-(defun ensure-non-standard-class (name &optional existing-class)
+(defun ensure-non-standard-class (name classoid &optional existing-class)
(flet
((ensure (metaclass &optional (slots nil slotsp))
- (let ((supers
- (mapcar #'classoid-name (classoid-direct-superclasses
- (find-classoid name)))))
+ (let ((supers (mapcar #'classoid-name (classoid-direct-superclasses classoid))))
(if slotsp
(ensure-class-using-class existing-class name
:metaclass metaclass :name name
((condition-type-p name)
(ensure 'condition-class
(mapcar #'slot-initargs-from-condition-slot
- (condition-classoid-slots (find-classoid name)))))
+ (condition-classoid-slots classoid))))
(t
(error "~@<~S is not the name of a class.~@:>" name)))))
(defun ensure-deffoo-class (classoid)
(let ((class (classoid-pcl-class classoid)))
(cond (class
- (ensure-non-standard-class (class-name class) class))
+ (ensure-non-standard-class (class-name class) classoid class))
((eq 'complete *boot-state*)
- (ensure-non-standard-class (classoid-name classoid))))))
+ (ensure-non-standard-class (classoid-name classoid) classoid)))))
(pushnew 'ensure-deffoo-class sb-kernel::*defstruct-hooks*)
(pushnew 'ensure-deffoo-class sb-kernel::*define-condition-hooks*)
(setf (info :type :translator class)
(lambda (spec) (declare (ignore spec)) classoid)))))
-(clrhash *find-class*)
(!bootstrap-meta-braid)
(!bootstrap-accessor-definitions t)
(!bootstrap-class-predicates t)
(!bootstrap-class-predicates nil)
(!bootstrap-built-in-classes)
-(dohash ((name x) *find-class*)
- (let* ((class (find-class-from-cell name x))
- (layout (class-wrapper class))
- (lclass (layout-classoid layout))
- (lclass-pcl-class (classoid-pcl-class lclass))
- (olclass (find-classoid name nil)))
- (if lclass-pcl-class
- (aver (eq class lclass-pcl-class))
- (setf (classoid-pcl-class lclass) class))
-
- (update-lisp-class-layout class layout)
-
- (cond (olclass
- (aver (eq lclass olclass)))
- (t
- (setf (find-classoid name) lclass)))
-
- (set-class-type-translation class name)))
+(dohash ((name x) sb-kernel::*classoid-cells*)
+ (when (classoid-cell-pcl-class x)
+ (let* ((class (find-class-from-cell name x))
+ (layout (class-wrapper class))
+ (lclass (layout-classoid layout))
+ (lclass-pcl-class (classoid-pcl-class lclass))
+ (olclass (find-classoid name nil)))
+ (if lclass-pcl-class
+ (aver (eq class lclass-pcl-class))
+ (setf (classoid-pcl-class lclass) class))
+
+ (update-lisp-class-layout class layout)
+
+ (cond (olclass
+ (aver (eq lclass olclass)))
+ (t
+ (setf (find-classoid name) lclass)))
+
+ (set-class-type-translation class name))))
(setq *boot-state* 'braid)
;; FIXME: do we still need this?
((and (null args) (typep type 'classoid))
(or (classoid-pcl-class type)
- (ensure-non-standard-class (classoid-name type))))
+ (ensure-non-standard-class (classoid-name type) type)))
((specializerp type) type)))
;;; interface
;;; and use that to replace all three variables.)
(defvar *pcl-package* (find-package "SB-PCL"))
+(declaim (inline defstruct-classoid-p))
+(defun defstruct-classoid-p (classoid)
+ ;; It is non-obvious to me why STRUCTURE-CLASSOID-P doesn't
+ ;; work instead of this. -- NS 2008-03-14
+ (typep (layout-info (classoid-layout classoid)) 'defstruct-description))
+
;;; This excludes structure types created with the :TYPE option to
;;; DEFSTRUCT. It also doesn't try to deal with types created by
;;; hairy DEFTYPEs, e.g.
;;; it needs a more mnemonic name. -- WHN 19991204
(defun structure-type-p (type)
(and (symbolp type)
- (not (condition-type-p type))
(let ((classoid (find-classoid type nil)))
(and classoid
- (typep (layout-info
- (classoid-layout classoid))
- 'defstruct-description)))))
+ (not (condition-classoid-p classoid))
+ (defstruct-classoid-p classoid)))))
;;; Symbol contruction utilities
(defun format-symbol (package format-string &rest format-arguments)
(/show "pcl/macros.lisp 119")
-(defvar *find-class* (make-hash-table :test 'eq))
-
-(defmacro find-class-cell-class (cell)
- `(car ,cell))
-
-(defmacro find-class-cell-predicate (cell)
- `(cadr ,cell))
-
-(defmacro make-find-class-cell (class-name)
- (declare (ignore class-name))
- '(list* nil #'constantly-nil nil))
-
-(defun find-class-cell (symbol &optional dont-create-p)
- (let ((table *find-class*))
- (with-locked-hash-table (table)
- (or (gethash symbol table)
- (unless dont-create-p
- (unless (legal-class-name-p symbol)
- (error "~S is not a legal class name." symbol))
- (setf (gethash symbol table) (make-find-class-cell symbol)))))))
-
-(/show "pcl/macros.lisp 157")
+(declaim (inline legal-class-name-p))
+(defun legal-class-name-p (x)
+ (symbolp x))
(defvar *create-classes-from-internal-structure-definitions-p* t)
(defun find-class-from-cell (symbol cell &optional (errorp t))
- (or (find-class-cell-class cell)
- (and *create-classes-from-internal-structure-definitions-p*
- (or (structure-type-p symbol) (condition-type-p symbol))
- (ensure-non-standard-class symbol))
+ (or (when cell
+ (or (classoid-cell-pcl-class cell)
+ (when *create-classes-from-internal-structure-definitions-p*
+ (let ((classoid (classoid-cell-classoid cell)))
+ (when (and classoid
+ (or (condition-classoid-p classoid)
+ (defstruct-classoid-p classoid)))
+ (ensure-non-standard-class symbol classoid))))))
(cond ((null errorp) nil)
((legal-class-name-p symbol)
(error "There is no class named ~S." symbol))
(t
(error "~S is not a legal class name." symbol)))))
-(defun legal-class-name-p (x)
- (symbolp x))
-
(defun find-class (symbol &optional (errorp t) environment)
(declare (ignore environment))
(find-class-from-cell symbol
- (find-class-cell symbol errorp)
+ (find-classoid-cell symbol)
errorp))
\f
(constantp errorp)
(member *boot-state* '(braid complete)))
(let ((errorp (not (null (constant-form-value errorp))))
- (class-cell (make-symbol "CLASS-CELL")))
- `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))
- (or (find-class-cell-class ,class-cell)
+ (cell (make-symbol "CLASSOID-CELL")))
+ `(let ((,cell (load-time-value (find-classoid-cell ',symbol :create t))))
+ (or (classoid-cell-pcl-class ,cell)
,(if errorp
- `(find-class-from-cell ',symbol ,class-cell t)
- `(and (classoid-cell-classoid
- ',(find-classoid-cell symbol))
- (find-class-from-cell ',symbol ,class-cell nil))))))
+ `(find-class-from-cell ',symbol ,cell t)
+ `(when (classoid-cell-classoid ,cell)
+ (find-class-from-cell ',symbol ,cell nil))))))
form))
+(declaim (inline class-classoid))
+(defun class-classoid (class)
+ (layout-classoid (class-wrapper class)))
+
(defun (setf find-class) (new-value name &optional errorp environment)
(declare (ignore errorp environment))
(cond ((legal-class-name-p name)
(with-single-package-locked-error
- (:symbol name "using ~A as the class-name argument in ~
+ (:symbol name "Using ~A as the class-name argument in ~
(SETF FIND-CLASS)"))
- (let* ((cell (find-class-cell name))
- (class (find-class-cell-class cell)))
- (setf (find-class-cell-class cell) new-value)
- (when (eq *boot-state* 'complete)
- (if (null new-value)
- (progn
- (setf (find-classoid name) new-value)
- (when class
- ;; KLUDGE: This horror comes about essentially
- ;; because we use the proper name of a classoid
- ;; to do TYPEP, which needs to be available
- ;; early, and also to determine whether TYPE-OF
- ;; should return the name or the class (using
- ;; CLASSOID-PROPER-NAME). So if we are removing
- ;; proper nameness, arrange for
- ;; CLASSOID-PROPER-NAME to do the right thing
- ;; too. (This is almost certainly not the right
- ;; solution; instead, CLASSOID-NAME and
- ;; FIND-CLASSOID should be direct parallels to
- ;; CLASS-NAME and FIND-CLASS, and TYPEP on
- ;; not-yet-final classes should be compileable.
- (let ((classoid (layout-classoid (slot-value class 'wrapper))))
- (setf (classoid-name classoid) nil))))
-
- (let ((classoid (layout-classoid (slot-value new-value 'wrapper))))
- (setf (find-classoid name) classoid)
- (set-class-type-translation new-value classoid))))
+ (let ((cell (find-classoid-cell name :create new-value)))
+ (cond (new-value
+ (setf (classoid-cell-pcl-class cell) new-value)
+ (when (eq *boot-state* 'complete)
+ (let ((classoid (class-classoid new-value)))
+ (setf (find-classoid name) classoid)
+ (set-class-type-translation new-value classoid))))
+ (cell
+ (clear-classoid name cell)))
(when (or (eq *boot-state* 'complete)
(eq *boot-state* 'braid))
(update-ctors 'setf-find-class :class new-value :name name))
(declaim (inline wrapper-class*))
(defun wrapper-class* (wrapper)
(or (wrapper-class wrapper)
- (ensure-non-standard-class
- (classoid-name (layout-classoid wrapper)))))
+ (let ((classoid (layout-classoid wrapper)))
+ (ensure-non-standard-class
+ (classoid-name classoid)
+ classoid))))
;;; The wrapper cache machinery provides general mechanism for
;;; trapping on the next access to any instance of a given class. This
#+sb-thread
(with-test (:name without-interrupts+get-mutex)
(let* ((lock (make-mutex))
- (foo (get-mutex lock))
- (bar nil)
+ (bar (progn (get-mutex lock) nil))
(thread (make-thread (lambda ()
(sb-sys:without-interrupts
(with-mutex (lock)
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.15.30"
+"1.0.15.31"
projects / sbcl.git / commitdiff