From 8cee9ed7432b03237f621eee6ba4b57fb352e6f1 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Wed, 21 Mar 1990 23:23:46 +0000
Subject: [PATCH] Added :type, :ref-known, :set-known options for slots.  When
 specified, they will cause a defknown to be generated before the VOPs that
 translate them.

---
 compiler/mips/cell.lisp | 20 ++++++++++++++++++--
 1 file changed, 18 insertions(+), 2 deletions(-)

diff --git a/compiler/mips/cell.lisp b/compiler/mips/cell.lisp
index 0cda73e1b..721b2c100 100644
--- a/compiler/mips/cell.lisp
+++ b/compiler/mips/cell.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.27 1990/03/20 00:43:16 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.28 1990/03/21 23:23:46 wlott Exp $
 ;;;
 ;;;    This file contains the VM definition of various primitive memory access
 ;;; VOPs for the MIPS.
@@ -26,6 +26,7 @@
 (vm:define-for-each-primitive-object (obj)
   (collect ((forms))
     (let* ((options (vm:primitive-object-options obj))
+	   (obj-type (getf options :type t))
 	   (alloc-trans (getf options :alloc-trans))
 	   (alloc-vop (getf options :alloc-vop alloc-trans))
 	   (header (vm:primitive-object-header obj))
@@ -41,8 +42,10 @@
 		 (offset (vm:slot-offset slot))
 		 (rest-p (vm:slot-rest-p slot))
 		 (slot-opts (vm:slot-options slot))
+		 (slot-type (getf slot-opts :type t))
 		 (ref-trans (getf slot-opts :ref-trans))
 		 (ref-vop (getf slot-opts :ref-vop ref-trans))
+		 (ref-known (getf slot-opts :ref-known))
 		 (set-trans (getf slot-opts :set-trans))
 		 (setf-vop (getf slot-opts :setf-vop
 				 (when (and (listp set-trans)
@@ -53,12 +56,25 @@
 					    "SET-"
 					    (string (cadr set-trans)))))))
 		 (set-vop (getf slot-opts :set-vop
-				(if setf-vop nil set-trans))))
+				(if setf-vop nil set-trans)))
+		 (set-known (getf slot-opts :set-known)))
+	    (when ref-known
+	      (if ref-trans
+		  (forms `(defknown (,ref-trans) (,obj-type) ,slot-type
+			    ,ref-known))
+		  (error "Can't spec a :ref-known with no :ref-trans. ~S in ~S"
+			 name (vm:primitive-object-name obj))))
 	    (when ref-vop
 	      (forms `(define-vop (,ref-vop ,(if rest-p 'slot-ref 'cell-ref))
 			(:variant ,offset ,lowtag)
 			,@(when ref-trans
 			    `((:translate ,ref-trans))))))
+	    (when set-known
+	      (if set-trans
+		  (forms `(defknown (,set-trans) (,obj-type ,slot-type)
+			    ,slot-type ,set-known))
+		  (error "Can't spec a :set-known with no :set-trans. ~S in ~S"
+			 name (vm:primitive-object-name obj))))
 	    (when (or set-vop setf-vop)
 	      (forms `(define-vop ,(cond ((and rest-p setf-vop)
 		  (error "Can't automatically generate a setf VOP for :rest-p ~
-- 
GitLab