From 0d2eb2cbffe9234651f974608ca6eafde9c16d37 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Tue, 9 Oct 1990 23:03:53 +0000
Subject: [PATCH] Replaced all uses of %primitive structure{-index,}-{ref,set}
 with the magic function structure-ref and it's setf method.

---
 code/defstruct.lisp | 57 ++++++++++++++++++++++++++++++---------------
 1 file changed, 38 insertions(+), 19 deletions(-)

diff --git a/code/defstruct.lisp b/code/defstruct.lisp
index 88db1f8e8..815638b5a 100644
--- a/code/defstruct.lisp
+++ b/code/defstruct.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.12 1990/10/05 15:51:19 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.13 1990/10/09 23:03:53 wlott Exp $
 ;;;
 ;;; Defstruct structure definition package (Mark II).
 ;;; Written by Skef Wholey and Rob MacLachlan.
@@ -15,8 +15,30 @@
 (in-package 'c)
 (export '(lisp::defstruct) "LISP")
 
+
+;;;; Structure frobbing primitives.
+
 ;;; Note: STRUCTURIFY is defined in struct.lisp.  It converts a simple-vector
-;;; into a structure.
+;;; into a structure.  It should go away when we have a real structure
+;;; allocation primitive.
+
+(defun structure-length (x)
+  "Return the number of slots used by the structure object X, including the
+  type slot."
+  (declare (type structure x))
+  (structure-length x))
+
+(defun structure-ref (struct index)
+  "Return the value from the INDEXth slot of STRUCT.  0 corresponds to the
+  type.  This is SETFable."
+  (structure-ref struct index)
+
+(defun structure-set (struct index new-value)
+  "Set the INDEXth slot of STRUCT to NEW-VALUE."
+  (setf (structure-ref struct index) new-value))
+
+(defsetf structure-ref structure-set)
+
 
 
 ;;; This version of Defstruct is implemented using Defstruct, and is free of
@@ -286,7 +308,7 @@
 (defun typep-to-structure (obj info)
   (declare (type defstruct-description info) (inline member))
   (and (structurep obj)
-       (let ((name (%primitive structure-ref obj 0)))
+       (let ((name (structure-ref obj 0)))
 	 (or (eq name (dd-name info))
 	     (member name (dd-included-by info) :test #'eq)))))
 
@@ -309,7 +331,7 @@
 		(unless (typep-to-structure structure info)
 		  (error "Structure for accessor ~S is not a ~S:~% ~S"
 			 (dsd-accessor dsd) (dd-name info) structure))
-		(%primitive structure-index-ref structure (dsd-index dsd))))
+		(structure-ref structure (dsd-index dsd))))
       
       (unless (dsd-read-only slot)
 	(setf (fdefinition `(setf ,(dsd-accessor slot)))
@@ -323,8 +345,8 @@
 		    (error "New-Value for setter ~S is not a ~S:~% ~S."
 			   `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
 			   new-value))
-		  (%primitive structure-index-set structure (dsd-index dsd)
-			      new-value))))))
+		  (setf (structure-ref structure (dsd-index dsd))
+			new-value))))))
 
   (when (dd-predicate info)
     (setf (symbol-function (dd-predicate info))
@@ -343,13 +365,13 @@
 	      (let ((len (dd-length info)))
 		(declare (fixnum len))
 		(do ((i 1 (1+ i))
-		     (res (%primitive alloc-g-vector len nil)))
+		     (res (structurify (%primitive alloc-g-vector len nil))))
 		    ((= i len)
-		     (%primitive structure-set res (dd-name info) 0)
-		     (structurify res))
+		     (setf (structure-ref res 0) (dd-name info))
+		     res)
 		  (declare (fixnum i))
-		  (%primitive structure-index-set res i
-			      (%primitive structure-index-ref structure i)))))))
+		  (setf (structure-ref res i)
+			(structure-ref structure i)))))))
   (when (dd-doc info)
     (setf (documentation (dd-name info) 'type) (dd-doc info))))
 
@@ -565,7 +587,7 @@
   (let ((def (info type structure-info type)))
     (if (and def (eq (dd-type def) 'structure) (dd-predicate def))
 	`(and (structurep ,object)
-	      (if (eq (%primitive structure-ref ,object 0) ',type)
+	      (if (eq (structure-ref ,object 0) ',type)
 		  t
 		  (,(dd-predicate def) ,object)))
 	`(lisp::structure-typep ,object ',type))))
@@ -575,7 +597,7 @@
 
 (defun default-structure-print (structure stream depth)
   (declare (ignore depth))
-  (let* ((type (%primitive structure-ref structure 0))
+  (let* ((type (structure-ref structure 0))
 	 (dd (info type defined-structure-info type)))
     (cond (*print-pretty*
 	   (let ((index 0))
@@ -591,8 +613,7 @@
 		 (prin1 (dsd-name (xp:pprint-pop)) stream)
 		 (write-char #\space stream)
 		 (xp:pprint-newline :miser stream)
-		 (prin1 (%primitive structure-index-ref structure (incf index))
-			stream)
+		 (prin1 (structure-ref structure (incf index)) stream)
 		 (xp:pprint-exit-if-list-exhausted)
 		 (write-char #\space stream)
 		 (xp:pprint-newline :linear stream)))))
@@ -600,8 +621,7 @@
 	   (write-string "#S(" stream)
 	   (prin1 type stream)
 	   (do ((index 1 (1+ index))
-		(length (truly-the index
-				   (%primitive structure-ref structure -1)))
+		(length (structure-length structure))
 		(slots (dd-slots dd) (cdr slots)))
 	       ((or (= index length)
 		    (and *print-length*
@@ -613,5 +633,4 @@
 	     (write-char #\space stream)
 	     (prin1 (dsd-name (car slots)) stream)
 	     (write-char #\space stream)
-	     (prin1 (%primitive structure-index-ref structure index)
-		    stream))))))
+	     (prin1 (structure-ref structure index) stream))))))
-- 
GitLab