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

Added type codes for internal object types such as CODE-COMPONENT. Ripped out

NS-BOOT conditionals.
parent afbc26b6
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.12 1993/02/23 15:51:56 ram Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.13 1993/03/01 20:04:08 ram Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -43,10 +43,8 @@ ...@@ -43,10 +43,8 @@
(defvar lisp::*initial-layouts*) (defvar lisp::*initial-layouts*)
(cold-load-init (cold-load-init
(setq *forward-referenced-layouts* (make-hash-table :test #'equal)) (setq *forward-referenced-layouts* (make-hash-table :test #'equal))
#-ns-boot
(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)))
#-ns-boot
(makunbound 'lisp::*initial-layouts*)) (makunbound 'lisp::*initial-layouts*))
...@@ -218,28 +216,6 @@ ...@@ -218,28 +216,6 @@
;;;; Class namespace: ;;;; Class namespace:
#+ns-boot
(defun find-structure-class (name)
(let ((info (info type structure-info name)))
(when info
(let* ((res (setf (info type class name)
(make-structure-class :name name)))
(includes (c::dd-includes info))
(super (find-class
(if includes
(first includes)
'structure-object)))
(super-layout (class-layout super))
(layout
(find-layout name (c::dd-length info)
(concatenate 'vector
(layout-inherits super-layout)
(vector super-layout))
(1+ (layout-inheritance-depth super-layout)))))
(register-layout layout nil nil)
res))))
;;; FIND-CLASS -- Public ;;; FIND-CLASS -- Public
;;; ;;;
...@@ -247,11 +223,7 @@ ...@@ -247,11 +223,7 @@
"Return the class with the specified Name. If ERRORP is false, then NIL is "Return the class with the specified Name. If ERRORP is false, then NIL is
returned when no such class exists." returned when no such class exists."
(declare (type symbol name) (ignore environment)) (declare (type symbol name) (ignore environment))
(let ((res #-ns-boot (let ((res (info type class name)))
(info type class name)
#+ns-boot
(or (info type class name)
(find-structure-class name))))
(if (or res (not errorp)) (if (or res (not errorp))
res res
(error "Class not yet defined:~% ~S" name)))) (error "Class not yet defined:~% ~S" name))))
...@@ -260,7 +232,7 @@ ...@@ -260,7 +232,7 @@
(declare (type class new-value)) (declare (type class new-value))
(ecase (info type kind name) (ecase (info type kind name)
((nil)) ((nil))
(#+ns-boot (:instance :structure) #-ns-boot :instance (:instance
(let ((old (class-of (info type class name))) (let ((old (class-of (info type class name)))
(new (class-of new-value))) (new (class-of new-value)))
(unless (eq old new) (unless (eq old new)
...@@ -427,15 +399,13 @@ ...@@ -427,15 +399,13 @@
(symbol :codes (#.vm:symbol-header-type)) (symbol :codes (#.vm:symbol-header-type))
(instance :state :read-only) (instance :state :read-only)
#+ns-boot
(structure-object :state :read-only :inherits (instance)) (system-area-pointer :codes (#.vm:sap-type))
(weak-pointer :codes (#.vm:weak-pointer-type))
(system-area-pointer) (scavenger-hook #+gengc :codes #+gengc (#.vm:scavenger-hook-type))
(weak-pointer) (code-component :codes (#.vm:code-header-type))
(scavenger-hook) (lra :codes (#.vm:return-pc-header-type))
(code-component) (fdefn :codes (#.vm:fdefn-type))
(lra)
(fdefn)
(random-class) ; Used for unknown type codes. (random-class) ; Used for unknown type codes.
(function (function
...@@ -446,7 +416,7 @@ ...@@ -446,7 +416,7 @@
:state :read-only) :state :read-only)
(generic-function :inherits (function) :state :read-only (generic-function :inherits (function) :state :read-only
:codes (#.vm:funcallable-instance-header-type)) :codes (#.vm:funcallable-instance-header-type))
(array :translation array (array :translation array
:hierarchical nil :codes (#.vm:complex-array-type)) :hierarchical nil :codes (#.vm:complex-array-type))
(simple-array :translation simple-array :inherits (array) (simple-array :translation simple-array :inherits (array)
...@@ -600,18 +570,10 @@ ...@@ -600,18 +570,10 @@
;;; ;;;
;;; ### special-case funcallable-instance ;;; ### special-case funcallable-instance
;;; ;;;
#-ns-boot
(declaim (inline layout-of)) (declaim (inline layout-of))
(defun layout-of (x) (defun layout-of (x)
(cond #-ns-boot (cond ((%instancep x) (%instance-layout x))
((%instancep x) (%instance-layout x))
#+ns-boot
((structurep x)
(class-layout (find-class (structure-ref x 0))))
#-ns-boot
((null x) '#.(class-layout (find-class 'null))) ((null x) '#.(class-layout (find-class 'null)))
#+ns-boot
((null x) (class-layout (find-class 'null)))
(t (svref built-in-class-codes (get-type x))))) (t (svref built-in-class-codes (get-type x)))))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment