From 59429c2a87cd5b65841f599f63e55e781f8de7af Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 15 Nov 2018 23:06:35 -0800
Subject: [PATCH] Implement new-make-define-structure-type without the obsolete
 argument.

Temporarily preserve make-define-structure-type which ignores the arg.
---
 src/edwin/clscon.scm    |  3 +--
 src/runtime/defstr.scm  |  5 +----
 src/runtime/random.scm  | 15 +++++++--------
 src/runtime/record.scm  | 15 +++++++++++----
 src/runtime/runtime.pkg |  1 +
 src/runtime/thread.scm  | 30 ++++++++++++++----------------
 6 files changed, 35 insertions(+), 34 deletions(-)

diff --git a/src/edwin/clscon.scm b/src/edwin/clscon.scm
index 0494d9375..a6f2bce99 100644
--- a/src/edwin/clscon.scm
+++ b/src/edwin/clscon.scm
@@ -51,13 +51,12 @@ USA.
 				       (and superclass
 					    (class-methods superclass))))))
 	       (named-structure/set-tag-description! class
-		 (make-define-structure-type
+		 (new-make-define-structure-type
 		  'VECTOR
 		  name
 		  (list->vector (map car transforms))
 		  (list->vector (map cdr transforms))
 		  (make-vector (length transforms) (lambda () #f))
-		  (standard-print-method name)
 		  class
 		  object-size))
 	       class))))
diff --git a/src/runtime/defstr.scm b/src/runtime/defstr.scm
index cde702564..dbe67a64b 100644
--- a/src/runtime/defstr.scm
+++ b/src/runtime/defstr.scm
@@ -811,15 +811,12 @@ differences:
 				    `',name))
 			      field-names
 			      inits)))
-	       `(,(absolute 'make-define-structure-type context)
+	       `(,(absolute 'new-make-define-structure-type context)
 		 ',(structure/physical-type structure)
 		 ',name
 		 '#(,@field-names)
 		 '#(,@(map slot/index slots))
 		 (vector ,@inits)
-		 ;; This field was the print-procedure, no longer used.
-		 ;; It should be removed after 9.3 is released.
-		 #f
 		 ,(if (and tag-expression
 			   (not (eq? tag-expression type-name)))
 		      (close tag-expression context)
diff --git a/src/runtime/random.scm b/src/runtime/random.scm
index 71d165105..3ed4509c2 100644
--- a/src/runtime/random.scm
+++ b/src/runtime/random.scm
@@ -520,11 +520,10 @@ USA.
     (lambda ()
       (random-source-randomize! default-random-source)))
   (named-structure/set-tag-description! random-state-tag
-    (make-define-structure-type 'vector
-				'random-state
-				'#(key)
-				'#(1)
-				(make-vector 1 (lambda () #f))
-				#f
-				random-state-tag
-				2)))
\ No newline at end of file
+    (new-make-define-structure-type 'vector
+				    'random-state
+				    '#(key)
+				    '#(1)
+				    (make-vector 1 (lambda () #f))
+				    random-state-tag
+				    2)))
\ No newline at end of file
diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index e2e7bc8cb..01df9a4c2 100644
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -564,7 +564,8 @@ USA.
 ;;;; Runtime support for DEFINE-STRUCTURE
 
 (define rtd:structure-type)
-(define make-define-structure-type)
+;; RELNOTE: rename without "new-"
+(define new-make-define-structure-type)
 (define structure-type?)
 (define structure-type/physical-type)
 (define structure-type/name)
@@ -579,9 +580,8 @@ USA.
    (set! rtd:structure-type
 	 (make-record-type "structure-type"
 			   '(physical-type name field-names field-indexes
-					   default-inits unparser-method tag
-					   length)))
-   (set! make-define-structure-type
+					   default-inits tag length)))
+   (set! new-make-define-structure-type
 	 (record-constructor rtd:structure-type))
    (set! structure-type?
 	 (record-predicate rtd:structure-type))
@@ -601,6 +601,13 @@ USA.
 	 (record-accessor rtd:structure-type 'length))
    unspecific))
 
+;; RELNOTE: delete
+(define (make-define-structure-type physical-type name field-names field-indexes
+				    default-inits unparser-method tag length)
+  (declare (ignore unparser-method))
+  (new-make-define-structure-type physical-type name field-names field-indexes
+				  default-inits tag length))
+
 (define-integrable (structure-type/field-index type field-name)
   (vector-ref (structure-type/field-indexes type)
 	      (structure-type/field-name-index type field-name)))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 5b29ff5e7..0b7f6fa64 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3824,6 +3824,7 @@ USA.
 	  named-list?
 	  named-structure?
 	  named-vector?
+	  new-make-define-structure-type ;RELNOTE: rename without "new-"
 	  record-accessor
 	  record-applicator
 	  record-constructor
diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 3fb29d404..4a95f8322 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -145,23 +145,21 @@ USA.
   (add-event-receiver! event:after-restore reset-threads!)
   (add-event-receiver! event:before-exit stop-thread-timer)
   (named-structure/set-tag-description! thread-mutex-tag
-    (make-define-structure-type 'vector
-				"thread-mutex"
-				'#(waiting-threads owner)
-				'#(1 2)
-				(vector 2 (lambda () #f))
-				#f
-				thread-mutex-tag
-				3))
+    (new-make-define-structure-type 'vector
+				    "thread-mutex"
+				    '#(waiting-threads owner)
+				    '#(1 2)
+				    (vector 2 (lambda () #f))
+				    thread-mutex-tag
+				    3))
   (named-structure/set-tag-description! link-tag
-    (make-define-structure-type 'vector
-				"link"
-				'#(prev next item)
-				'#(1 2 3)
-				(vector 3 (lambda () #f))
-				#f
-				link-tag
-				4)))
+    (new-make-define-structure-type 'vector
+				    "link"
+				    '#(prev next item)
+				    '#(1 2 3)
+				    (vector 3 (lambda () #f))
+				    link-tag
+				    4)))
 
 (define-print-method link?
   (standard-print-method 'link))
-- 
2.25.1