From: Taylor R Campbell <campbell@mumble.net>
Date: Sat, 9 Feb 2019 16:14:57 +0000 (+0000)
Subject: Integrate record accessors and modifiers where convenient.
X-Git-Tag: mit-scheme-pucked-10.1.10~6^2~14
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=238e03512fb58579bdf78b902ed4c4e83232164a;p=mit-scheme.git

Integrate record accessors and modifiers where convenient.

Limited to record types with:

- a defined predicate name we can pass to GUARANTEE, and
- no parent type so we can statically determine the field offsets.

Obviously it would be better if the compiler could do the flow
analysis to figure out where it can statically partially evaluate
RECORD-ACCESSOR and RECORD-MODIFIER, but, y'know, exercise for the
reader.
---

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index 5ffa658b9..54f5d0a04 100644
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -852,23 +852,77 @@ USA.
 		    (scons-define pred-name
 		      (scons-call (scons-close 'record-predicate) type-name))
 		    (default-object))
-		(append-map (lambda (field-spec)
+		(append-map (lambda (field-spec index)
 			      (let ((name (car field-spec))
 				    (accessor (cadr field-spec))
 				    (modifier (caddr field-spec)))
-				(list (scons-define accessor
-					(scons-call
-					 (scons-close 'record-accessor)
-					 type-name
-					 (scons-quote name)))
-				      (if modifier
-					  (scons-define modifier
-					    (scons-call
-					     (scons-close 'record-modifier)
-					     type-name
-					     (scons-quote name)))
-					  (default-object)))))
-			    field-specs)))))))
+				(append
+				 (scons-record-accessor
+				  accessor
+				  type-name
+				  parent
+				  pred-name
+				  name
+				  index)
+				 (if modifier
+				     (scons-record-modifier
+				      modifier
+				      type-name
+				      parent
+				      pred-name
+				      name
+				      index)
+				     '()))))
+			    field-specs
+			    ;; Start at 1, after the record type descriptor.
+			    (iota (length field-specs) 1))))))))
+
+(define (scons-record-accessor accessor type-name parent pred-name name index)
+  (if (and (not parent)
+	   pred-name)
+      (list
+       (scons-declare (list 'integrate-operator accessor))
+       (scons-define accessor
+	 (let ((object (new-identifier 'object)))
+	   (scons-named-lambda (list accessor object)
+	     (scons-if
+	      (scons-and (scons-call (scons-close '%record?) object)
+			 (scons-call
+			  (scons-close 'eq?)
+			  type-name
+			  (scons-call (scons-close '%record-ref) object 0)))
+	      (unspecific-expression)
+	      (scons-call (scons-close 'guarantee) pred-name object accessor))
+	     (scons-call (scons-close '%record-ref) object index)))))
+      (list
+       (scons-define
+	(scons-call (scons-close 'record-accessor)
+		    type-name
+		    (scons-quote name))))))
+
+(define (scons-record-modifier modifier type-name parent pred-name name index)
+  (if (and (not parent)
+	   pred-name)
+      (list
+       (scons-declare (list 'integrate-operator modifier))
+       (scons-define modifier
+	 (let ((object (new-identifier 'object))
+	       (value (new-identifier 'value)))
+	   (scons-named-lambda (list modifier object value)
+	     (scons-if
+	      (scons-and (scons-call (scons-close '%record?) object)
+			 (scons-call
+			  (scons-close 'eq?)
+			  type-name
+			  (scons-call (scons-close '%record-ref) object 0)))
+	      (unspecific-expression)
+	      (scons-call (scons-close 'guarantee) pred-name object modifier))
+	     (scons-call (scons-close '%record-set!) object index value)))))
+      (list
+       (scons-define modifier
+	 (scons-call (scons-close 'record-modifier)
+		     type-name
+		     (scons-quote name))))))
 
 ;;;; MIT/GNU Scheme custom syntax