projects
/
sbcl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
1.0.12.33: Have foreign.test.sh create .so files under the test directory
[sbcl.git]
/
src
/
code
/
class.lisp
diff --git
a/src/code/class.lisp
b/src/code/class.lisp
index
e4cd365
..
082484c
100644
(file)
--- a/
src/code/class.lisp
+++ b/
src/code/class.lisp
@@
-101,7
+101,9
@@
;;; cold-load time.
(defvar *forward-referenced-layouts*)
(!cold-init-forms
;;; cold-load time.
(defvar *forward-referenced-layouts*)
(!cold-init-forms
- (setq *forward-referenced-layouts* (make-hash-table :test 'equal))
+ (setq *forward-referenced-layouts* (make-hash-table :test 'equal
+ #-sb-xc-host #-sb-xc-host
+ :synchronized t))
#-sb-xc-host (progn
(/show0 "processing *!INITIAL-LAYOUTS*")
(dolist (x *!initial-layouts*)
#-sb-xc-host (progn
(/show0 "processing *!INITIAL-LAYOUTS*")
(dolist (x *!initial-layouts*)
@@
-114,6
+116,13
@@
;;; type checking and garbage collection. Whenever a class is
;;; incompatibly redefined, a new layout is allocated. If two object's
;;; layouts are EQ, then they are exactly the same type.
;;; type checking and garbage collection. Whenever a class is
;;; incompatibly redefined, a new layout is allocated. If two object's
;;; layouts are EQ, then they are exactly the same type.
+;;;
+;;; *** IMPORTANT ***
+;;;
+;;; If you change the slots of LAYOUT, you need to alter genesis as
+;;; well, since the initialization of layout slots is hardcoded there.
+;;;
+;;; FIXME: ...it would be better to automate this, of course...
(def!struct (layout
;; KLUDGE: A special hack keeps this from being
;; called when building code for the
(def!struct (layout
;; KLUDGE: A special hack keeps this from being
;; called when building code for the
@@
-186,6
+195,9
@@
(n-untagged-slots 0 :type index)
;; Definition location
(source-location nil)
(n-untagged-slots 0 :type index)
;; Definition location
(source-location nil)
+ ;; Information about slots in the class to PCL: this provides fast
+ ;; access to slot-definitions and locations by name, etc.
+ (slot-table #(nil) :type simple-vector)
;; True IFF the layout belongs to a standand-instance or a
;; standard-funcallable-instance -- that is, true only if the layout
;; is really a wrapper.
;; True IFF the layout belongs to a standand-instance or a
;; standard-funcallable-instance -- that is, true only if the layout
;; is really a wrapper.
@@
-462,7
+474,7
@@
(when classoid-layout
(modify-classoid classoid)
(when subclasses
(when classoid-layout
(modify-classoid classoid)
(when subclasses
- (dohash (subclass subclass-layout subclasses)
+ (dohash ((subclass subclass-layout) subclasses :locked t)
(modify-classoid subclass)
(when invalidate
(invalidate-layout subclass-layout))))
(modify-classoid subclass)
(when invalidate
(invalidate-layout subclass-layout))))
@@
-485,7
+497,9
@@
(let* ((super (layout-classoid super-layout))
(subclasses (or (classoid-subclasses super)
(setf (classoid-subclasses super)
(let* ((super (layout-classoid super-layout))
(subclasses (or (classoid-subclasses super)
(setf (classoid-subclasses super)
- (make-hash-table :test 'eq)))))
+ (make-hash-table :test 'eq
+ #-sb-xc-host #-sb-xc-host
+ :synchronized t)))))
(when (and (eq (classoid-state super) :sealed)
(not (gethash classoid subclasses)))
(warn "unsealing sealed class ~S in order to subclass it"
(when (and (eq (classoid-state super) :sealed)
(not (gethash classoid subclasses)))
(warn "unsealing sealed class ~S in order to subclass it"
@@
-585,7
+599,7
@@
(when (zerop count)
(push successor free-objs))))))
(cond ((endp free-objs)
(when (zerop count)
(push successor free-objs))))))
(cond ((endp free-objs)
- (dohash (obj info obj-info)
+ (dohash ((obj info) obj-info)
(unless (zerop (first info))
(error "Topological sort failed due to constraint on ~S."
obj)))
(unless (zerop (first info))
(error "Topological sort failed due to constraint on ~S."
obj)))
@@
-822,7
+836,7
@@
NIL is returned when no such class exists."
(defun update-object-layout-or-invalid (object layout)
(if (typep (classoid-of object) 'standard-classoid)
(sb!pcl::check-wrapper-validity object)
(defun update-object-layout-or-invalid (object layout)
(if (typep (classoid-of object) 'standard-classoid)
(sb!pcl::check-wrapper-validity object)
- (%layout-invalid-error object layout)))
+ (sb!c::%layout-invalid-error object layout)))
;;; Simple methods for TYPE= and SUBTYPEP should never be called when
;;; the two classes are equal, since there are EQ checks in those
;;; Simple methods for TYPE= and SUBTYPEP should never be called when
;;; the two classes are equal, since there are EQ checks in those
@@
-848,7
+862,7
@@
NIL is returned when no such class exists."
(o-sub (classoid-subclasses other)))
(if (and s-sub o-sub)
(collect ((res *empty-type* type-union))
(o-sub (classoid-subclasses other)))
(if (and s-sub o-sub)
(collect ((res *empty-type* type-union))
- (dohash (subclass layout s-sub)
+ (dohash ((subclass layout) s-sub :locked t)
(declare (ignore layout))
(when (gethash subclass o-sub)
(res (specifier-type subclass))))
(declare (ignore layout))
(when (gethash subclass o-sub)
(res (specifier-type subclass))))
@@
-1464,7
+1478,7
@@
NIL is returned when no such class exists."
;;; late in the build-order.lisp-expr sequence, and be put in
;;; !COLD-INIT-FORMS there?
(defun !class-finalize ()
;;; late in the build-order.lisp-expr sequence, and be put in
;;; !COLD-INIT-FORMS there?
(defun !class-finalize ()
- (dohash (name layout *forward-referenced-layouts*)
+ (dohash ((name layout) *forward-referenced-layouts*)
(let ((class (find-classoid name nil)))
(cond ((not class)
(setf (layout-classoid layout) (make-undefined-classoid name)))
(let ((class (find-classoid name nil)))
(cond ((not class)
(setf (layout-classoid layout) (make-undefined-classoid name)))