Skip to content
Snippets Groups Projects
Commit f1adfe69 authored by ram's avatar ram
Browse files

Add stuff to initialize the layout hash. Add standard-class and

random-pcl-class for representing objects whose real class is a PCL
class.  Add class-pcl-class slot for tracking the PCL class of any class.
Changed layout invalidating to set to :INVALID, not T, since PCL uses T
to mean valid.
parent 8d1a65ee
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.25 1993/05/19 16:11:29 wlott Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.26 1993/07/10 16:14:17 ram Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -18,21 +18,24 @@ ...@@ -18,21 +18,24 @@
;;; ;;;
(in-package "KERNEL") (in-package "KERNEL")
(export '(layout layout-hash layout-hash-length layout-class layout-invalid (export '(layout layout-hash layout-hash-length layout-hash-max
initialize-layout-hash layout-class layout-invalid
layout-inherits layout-inheritance-depth layout-length layout-inherits layout-inheritance-depth layout-length
layout-info layout-pure layout-info layout-pure
layout-of structure-class-p layout-of structure-class-p
basic-structure-class-print-function basic-structure-class-print-function
structure-class-make-load-form-fun find-layout structure-class-make-load-form-fun find-layout
class-proper-name class-layout class-state class-subclasses class-proper-name class-layout class-state class-subclasses
class-init class-init register-layout
basic-structure-class funcallable-instance basic-structure-class funcallable-instance
funcallable-structure-class funcallable-structure-class
make-funcallable-structure-class make-funcallable-structure-class
funcallable-structure-class-p)) funcallable-structure-class-p make-standard-class
random-pcl-class make-random-pcl-class))
(in-package "LISP") (in-package "LISP")
(export '(class structure-class class-name find-class class-of built-in-class)) (export '(class structure-class standard-class class-name find-class class-of
built-in-class))
(in-package "KERNEL") (in-package "KERNEL")
...@@ -40,14 +43,19 @@ ...@@ -40,14 +43,19 @@
;;; Table mapping class names to layouts for classes we have referenced but not ;;; Table mapping class names to layouts for classes we have referenced but not
;;; yet loaded. This is initialized from an ALIST created by Genesis ;;; yet loaded. This is initialized from an ALIST created by Genesis
;;; describing the layouts it created at cold-load time. ;;; describing the layouts it created at cold-load time. *LAYOUT-HASH-INITS*
;;; is a list of all the layouts whose hash hasn't been initialized. We delay
;;; this because the random-number generator needs top-level forms to work.
;;; ;;;
(defvar *forward-referenced-layouts*) (defvar *forward-referenced-layouts*)
(defvar lisp::*initial-layouts*) (defvar lisp::*initial-layouts*)
(defvar *layout-hash-inits*)
(cold-load-init (cold-load-init
(setq *forward-referenced-layouts* (make-hash-table :test #'equal)) (setq *forward-referenced-layouts* (make-hash-table :test #'equal))
(setq *layout-hash-inits* ())
(dolist (x lisp::*initial-layouts*) (dolist (x lisp::*initial-layouts*)
(setf (gethash (car x) *forward-referenced-layouts*) (cdr x))) (setf (gethash (car x) *forward-referenced-layouts*) (cdr x))
(push (cdr x) *layout-hash-inits*))
(makunbound 'lisp::*initial-layouts*)) (makunbound 'lisp::*initial-layouts*))
...@@ -129,6 +137,26 @@ ...@@ -129,6 +137,26 @@
(declare (type layout layout) (type index new-value i)) (declare (type layout layout) (type index new-value i))
(setf (%instance-ref layout (1+ i)) new-value)) (setf (%instance-ref layout (1+ i)) new-value))
(defconstant layout-hash-max (ash most-positive-fixnum -3)
"The inclusive upper bound on LAYOUT-HASH values.")
(defvar *layout-hash-seed* nil)
;;; INITIALIZE-LAYOUT-HASH -- Interface
;;;
;;; Set the layout-hash slots to non-zero random numbers between 1 and
;;; layout-hash-max (inclusive.) The layout is returned.
;;;
(defun initialize-layout-hash (layout)
(let ((seed *layout-hash-seed*))
(unless seed
(setq seed (setq *layout-hash-seed* (make-random-state))))
(dotimes (i layout-hash-length)
(setf (layout-hash layout i)
(1+ (random layout-hash-max seed)))))
layout)
;;; The CLASS structure is a supertype of all CLASS types. A CLASS is also a ;;; The CLASS structure is a supertype of all CLASS types. A CLASS is also a
;;; CTYPE structure as recognized by the type system. ;;; CTYPE structure as recognized by the type system.
;;; ;;;
...@@ -154,7 +182,10 @@ ...@@ -154,7 +182,10 @@
;; class. NIL if no subclasses or not initalized yet. Otherwise, an EQ ;; class. NIL if no subclasses or not initalized yet. Otherwise, an EQ
;; hash-table mapping class-objects to the subclass layout that was in effect ;; hash-table mapping class-objects to the subclass layout that was in effect
;; at the time the subclass was created. ;; at the time the subclass was created.
(subclasses nil :type (or hash-table null))) (subclasses nil :type (or hash-table null))
;;
;; The PCL class object, or NIL if none assigned yet.
(pcl-class nil))
;;; ;;;
(defun class-make-load-form-fun (class) (defun class-make-load-form-fun (class)
(let ((name (class-name class))) (let ((name (class-name class)))
...@@ -698,7 +729,7 @@ ...@@ -698,7 +729,7 @@
;;; ;;;
(defun invalidate-layout (layout) (defun invalidate-layout (layout)
(declare (type layout layout)) (declare (type layout layout))
(setf (layout-invalid layout) t) (setf (layout-invalid layout) :invalid)
(setf (layout-inheritance-depth layout) -1) (setf (layout-inheritance-depth layout) -1)
(let ((inherits (layout-inherits layout)) (let ((inherits (layout-inherits layout))
(class (layout-class layout))) (class (layout-class layout)))
...@@ -848,6 +879,9 @@ ...@@ -848,6 +879,9 @@
:inherits inherits :inherits inherits
:inheritance-depth depth :inheritance-depth depth
:length length))) :length length)))
(if *type-system-initialized*
(initialize-layout-hash res)
(push res *layout-hash-inits*))
(cond ((not old) (cond ((not old)
(setf (gethash name *forward-referenced-layouts*) res)) (setf (gethash name *forward-referenced-layouts*) res))
((not *type-system-initialized*) ((not *type-system-initialized*)
...@@ -882,10 +916,20 @@ ...@@ -882,10 +916,20 @@
old))) old)))
(t old)))) (t old))))
;;; PCL stuff:
(defstruct (std-class (:include class)))
(defstruct (standard-class (:include std-class)))
(defstruct (random-pcl-class (:include std-class)))
;;;; Cold loading initializations. ;;;; Cold loading initializations.
(defun class-finalize () (defun class-finalize ()
(dolist (layout *layout-hash-inits*)
(initialize-layout-hash layout))
(makunbound '*layout-hash-inits*)
(do-hash (name layout *forward-referenced-layouts*) (do-hash (name layout *forward-referenced-layouts*)
(let ((class (find-class name nil))) (let ((class (find-class name nil)))
(cond ((not class) (cond ((not class)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment