From 64f8ac54db262f700e5eb80d6bfef0a9802c3c28 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Sat, 13 Mar 1993 11:11:10 +0000
Subject: [PATCH] Add basic-structure-class abstract superclass &
 funcallable-structure-class.

---
 code/class.lisp | 44 +++++++++++++++++++++++++++-----------------
 1 file changed, 27 insertions(+), 17 deletions(-)

diff --git a/code/class.lisp b/code/class.lisp
index a46ce2b98..e3f00fdd4 100644
--- a/code/class.lisp
+++ b/code/class.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.13 1993/03/01 20:04:08 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.14 1993/03/13 11:11:10 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -25,7 +25,8 @@
 		 structure-class-print-function
 		 structure-class-make-load-form-fun find-layout
 		 class-proper-name class-layout class-state class-subclasses
-		 class-init))
+		 class-init
+		 basic-structure-class funcallable-structure-class))
 
 (in-package "LISP")
 (export '(class structure-class class-name find-class class-of built-in-class
@@ -198,7 +199,9 @@
 ;;; Non-structure "typed" defstructs are a special case, and don't have a
 ;;; corresponding class.
 ;;;
-(defstruct (structure-class (:include class))
+(defstruct (basic-structure-class (:include class)))
+
+(defstruct (structure-class (:include basic-structure-class))
   ;;
   ;; Structure print function, or NIL if none.
   (print-function nil :type (or function symbol null))
@@ -214,6 +217,11 @@
   ;; If true, a default keyword constructor for this structure.
   (constructor nil :type (or function null)))
 
+;;; FUNCALLABLE-STRUCTURE-CLASS is used to represent funcallable structures,
+;;; which are used to implement generic functions.
+;;;
+(defstruct (funcallable-structure-class (:include basic-structure-class)))
+
 
 ;;;; Class namespace:
 
@@ -531,7 +539,7 @@
 			       (class-layout (find-class x)))
 			   inherits)
 		      (if hierarchical (length inherits) -1))
-	 nil nil)))))
+	 :invalidate nil)))))
 
 
 ;;; Now that we have set up the class heterarchy, seal the sealed classes.
@@ -613,6 +621,7 @@
   (setf (layout-inheritance-depth layout) -1)
   (let ((inherits (layout-inherits layout))
 	(class (layout-class layout)))
+    (modify-class class)
     (dotimes (i (length inherits))
       (let* ((super (svref inherits i))
 	     (subs (class-subclasses (layout-class super))))
@@ -628,13 +637,13 @@
 ;;; in the type system, clobbering any old layout.  However, this does not
 ;;; modify the class namespace; that is a separate operation (think anonymous
 ;;; classes.)
-;;; -- If INVALIDATE-P, then all the layouts for any old definition
+;;; -- If INVALIDATE, then all the layouts for any old definition
 ;;;    and subclasses are invalidated, and the SUBCLASSES slot is cleared.
-;;  -- If DESTRUCT-P, then there must be an old layout, and this old layout is
+;;  -- If DESTRUCT-LAYOUT, then this is some old layout, and is to be
 ;;;    destructively modified to hold the same type information.
 ;;;
-(defun register-layout (layout invalidate-p destruct-p)
-  (declare (type layout layout))
+(defun register-layout (layout &key (invalidate t) destruct-layout)
+  (declare (type layout layout) (type (or layout null) destruct-layout))
   (let* ((class (layout-class layout))
 	 (class-layout (class-layout class))
 	 (subclasses (class-subclasses class)))
@@ -644,18 +653,19 @@
       (when subclasses
 	(do-hash (c l subclasses)
 	  (modify-class c)
-	  (when invalidate-p (invalidate-layout l))))
-      (when invalidate-p
+	  (when invalidate (invalidate-layout l))))
+      (when invalidate
 	(invalidate-layout class-layout)
 	(setf (class-subclasses class) nil)))
     
-    (cond (destruct-p
-	   (setf (layout-invalid class-layout) nil)
-	   (setf (layout-inherits class-layout) (layout-inherits layout))
-	   (setf (layout-inheritance-depth class-layout)
+    (cond (destruct-layout
+	   (setf (layout-invalid destruct-layout) nil)
+	   (setf (layout-inherits destruct-layout) (layout-inherits layout))
+	   (setf (layout-inheritance-depth destruct-layout)
 		 (layout-inheritance-depth layout))
-	   (setf (layout-length class-layout) (layout-length layout))
-	   (setf (layout-info class-layout) (layout-info layout)))
+	   (setf (layout-length destruct-layout) (layout-length layout))
+	   (setf (layout-info destruct-layout) (layout-info layout))
+	   (setf (class-layout class) destruct-layout))
 	  (t
 	   (setf (layout-invalid layout) nil)
 	   (setf (class-layout class) layout)))
@@ -672,7 +682,7 @@
 		  (class-name super))
 	    (setf (class-state super) :read-only))
 	  (setf (gethash class subclasses)
-		(if destruct-p class-layout layout))))))
+		(or destruct-layout layout))))))
 
     (undefined-value))
 
-- 
GitLab