From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 10 Jan 2018 05:02:06 +0000 (-0800)
Subject: Eliminate use of record-specific printing registration.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~384
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a735e11a387d5b3bb1f913b73646f59cfe32fb40;p=mit-scheme.git

Eliminate use of record-specific printing registration.
---

diff --git a/src/edwin/edtstr.scm b/src/edwin/edtstr.scm
index cfed6ea23..58a8c6458 100644
--- a/src/edwin/edtstr.scm
+++ b/src/edwin/edtstr.scm
@@ -129,7 +129,7 @@ USA.
 (define (button-name button)
   (symbol->string (button-symbol button)))
 
-(set-record-type-unparser-method! <button>
+(define-unparser-method button?
   (simple-unparser-method (record-type-name <button>)
     (lambda (button)
       (list (button-symbol button)))))
diff --git a/src/runtime/binary-port.scm b/src/runtime/binary-port.scm
index 223bc907f..f11aefde1 100644
--- a/src/runtime/binary-port.scm
+++ b/src/runtime/binary-port.scm
@@ -85,13 +85,13 @@ USA.
 			'<= binary-input-port?
 			'<= binary-output-port?)))
 
-(set-record-type-unparser-method! <binary-port>
+(define-unparser-method binary-port?
   (standard-unparser-method
    (lambda (port)
-     (cond ((binary-i/o-port? port) 'BINARY-I/O-PORT)
-	   ((binary-input-port? port) 'BINARY-INPUT-PORT)
-	   ((binary-output-port? port) 'BINARY-OUTPUT-PORT)
-	   (else 'BINARY-PORT)))
+     (cond ((binary-i/o-port? port) 'binary-i/o-port)
+	   ((binary-input-port? port) 'binary-input-port)
+	   ((binary-output-port? port) 'binary-output-port)
+	   (else 'binary-port)))
    #f))
 
 ;;;; Bytevector input ports
diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index aac9d3e75..47bbdb8d7 100644
--- a/src/runtime/bundle.scm
+++ b/src/runtime/bundle.scm
@@ -186,7 +186,7 @@ USA.
 (define (define-bundle-printer interface printer)
   (hash-table-set! bundle-printers interface printer))
 
-(set-record-type-entity-unparser-method! <bundle-metadata>
+(define-unparser-method bundle?
   (standard-unparser-method
    (lambda (bundle)
      (bundle-interface-name (bundle-interface bundle)))
@@ -198,7 +198,7 @@ USA.
        (if printer
 	   (printer bundle port))))))
 
-(set-record-type-entity-describer! <bundle-metadata>
+(define-pp-describer bundle?
   (lambda (bundle)
     (map (lambda (name)
 	   (list name (bundle-ref bundle name)))
diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm
index 4bfd691dc..39fc9901e 100644
--- a/src/runtime/ffi.scm
+++ b/src/runtime/ffi.scm
@@ -45,7 +45,7 @@ USA.
 ;; two digits representing a larger number, then RADIX is their base.
 (define %radix)
 
-(set-record-type-unparser-method! rtd:alien
+(define-unparser-method alien?
   (standard-unparser-method
    'alien
    (lambda (alien port)
diff --git a/src/runtime/http-syntax.scm b/src/runtime/http-syntax.scm
index c8b8d70d9..f01baefe9 100644
--- a/src/runtime/http-syntax.scm
+++ b/src/runtime/http-syntax.scm
@@ -234,7 +234,7 @@ USA.
 
 (define-guarantee http-header "HTTP header field")
 
-(set-record-type-unparser-method! <http-header>
+(define-unparser-method http-header?
   (simple-unparser-method 'HTTP-HEADER
     (lambda (header)
       (list (http-header-name header)))))
diff --git a/src/runtime/httpio.scm b/src/runtime/httpio.scm
index e4caf4b0b..5304dc98d 100644
--- a/src/runtime/httpio.scm
+++ b/src/runtime/httpio.scm
@@ -49,7 +49,7 @@ USA.
       (guarantee-headers&body headers body 'MAKE-HTTP-REQUEST)
     (%make-http-request method uri version headers body)))
 
-(set-record-type-unparser-method! <http-request>
+(define-unparser-method http-request?
   (simple-unparser-method 'HTTP-REQUEST
     (lambda (request)
       (list (http-request-method request)
@@ -72,7 +72,7 @@ USA.
       (guarantee-headers&body headers body 'MAKE-HTTP-RESPONSE)
     (%make-http-response version status reason headers body)))
 
-(set-record-type-unparser-method! <http-response>
+(define-unparser-method http-response?
   (simple-unparser-method 'HTTP-RESPONSE
     (lambda (response)
       (list (http-response-status response)))))
diff --git a/src/runtime/packag.scm b/src/runtime/packag.scm
index b155dc85d..5b68da592 100644
--- a/src/runtime/packag.scm
+++ b/src/runtime/packag.scm
@@ -74,8 +74,8 @@ USA.
     (let ((tag (record-type-dispatch-tag rtd)))
       (set! package-tag tag)
       (for-each (lambda (p) (%record-set! p 0 tag)) *packages*))
-    (set-record-type-unparser-method! rtd
-      (simple-unparser-method 'PACKAGE
+    (define-unparser-method (record-predicate rtd)
+      (simple-unparser-method 'package
 	(lambda (package)
 	  (list (package/name package)))))))
 
diff --git a/src/runtime/port.scm b/src/runtime/port.scm
index 4e1e527c7..631f68299 100644
--- a/src/runtime/port.scm
+++ b/src/runtime/port.scm
@@ -60,7 +60,7 @@ USA.
   (flush-output port-type-operation:flush-output)
   (discretionary-flush-output port-type-operation:discretionary-flush-output))
 
-(set-record-type-unparser-method! <textual-port-type>
+(define-unparser-method textual-port-type?
   (standard-unparser-method
    (lambda (type)
      (if (port-type-supports-input? type)
@@ -422,7 +422,7 @@ USA.
    (register-predicate! textual-i/o-port? 'textual-i/o-port
 			'<= textual-port?)))
 
-(set-record-type-unparser-method! <textual-port>
+(define-unparser-method textual-port?
   (standard-unparser-method
    (lambda (port)
      (cond ((textual-i/o-port? port) 'TEXTUAL-I/O-PORT)
diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 9c59983ce..0c2d0a8b4 100644
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -534,23 +534,10 @@ USA.
 	       ,((record-accessor type field-name) record)))
 	   (record-type-field-names type)))))
 
-;;; These are for backwards compatibility:
-
+;;; For backwards compatibility:
 (define (set-record-type-unparser-method! record-type method)
   (define-unparser-method (record-predicate record-type)
     method))
-
-(define (set-record-type-describer! record-type describer)
-  (define-pp-describer (record-predicate record-type)
-    describer))
-
-(define (set-record-type-entity-unparser-method! record-type method)
-  (define-unparser-method (record-entity-predicate record-type)
-    method))
-
-(define (set-record-type-entity-describer! record-type describer)
-  (define-pp-describer (record-entity-predicate record-type)
-    describer))
 
 ;;;; Runtime support for DEFINE-STRUCTURE
 
diff --git a/src/runtime/rfc2822-headers.scm b/src/runtime/rfc2822-headers.scm
index 9d6dbbbe4..fc5e889bb 100644
--- a/src/runtime/rfc2822-headers.scm
+++ b/src/runtime/rfc2822-headers.scm
@@ -42,7 +42,7 @@ USA.
 
 (define-guarantee rfc2822-header "RFC 2822 header field")
 
-(set-record-type-unparser-method! <rfc2822-header>
+(define-unparser-method rfc2822-header?
   (simple-unparser-method 'rfc2822-header
     (lambda (header)
       (list (rfc2822-header-name header)))))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 78471db90..f3ced32ab 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3723,6 +3723,8 @@ USA.
 (define-package (runtime record)
   (files "record")
   (parent (runtime))
+  (export () deprecated:record
+	  set-record-type-unparser-method!)
   (export ()
 	  %copy-record
 	  %make-record
@@ -3766,11 +3768,7 @@ USA.
 	  record-type-name
 	  record-type?
 	  record-updater
-	  record?
-	  set-record-type-describer!
-	  set-record-type-entity-describer!
-	  set-record-type-entity-unparser-method!
-	  set-record-type-unparser-method!)
+	  record?)
   (export (runtime)
 	  error:no-such-slot
 	  error:uninitialized-slot
diff --git a/src/runtime/sfile.scm b/src/runtime/sfile.scm
index 0bca2af51..fe363867b 100644
--- a/src/runtime/sfile.scm
+++ b/src/runtime/sfile.scm
@@ -327,7 +327,7 @@ USA.
 (define top-level-mime-types
   '#(TEXT IMAGE AUDIO VIDEO APPLICATION MULTIPART MESSAGE))
 
-(set-record-type-unparser-method! <mime-type>
+(define-unparser-method mime-type?
   (standard-unparser-method 'MIME-TYPE
     (lambda (mime-type port)
       (write-char #\space port)
diff --git a/src/runtime/url.scm b/src/runtime/url.scm
index e7ad9d4b5..408b5bfb0 100644
--- a/src/runtime/url.scm
+++ b/src/runtime/url.scm
@@ -115,8 +115,8 @@ USA.
   (host uri-authority-host)
   (port uri-authority-port))
 
-(set-record-type-unparser-method! <uri-authority>
-  (simple-unparser-method 'URI-AUTHORITY
+(define-unparser-method uri-authority?
+  (simple-unparser-method 'uri-authority
     (lambda (authority)
       (list (call-with-output-string
 	      (lambda (port)
@@ -952,7 +952,7 @@ USA.
   (fragment partial-uri-fragment set-partial-uri-fragment!)
   (extra partial-uri-extra set-partial-uri-extra!))
 
-(set-record-type-unparser-method! <partial-uri>
+(define-unparser-method partial-uri?
   (standard-unparser-method 'PARTIAL-URI
     (lambda (puri port)
       (write-char #\space port)
diff --git a/src/xml/rdf-struct.scm b/src/xml/rdf-struct.scm
index c8d9c686b..e691d367c 100644
--- a/src/xml/rdf-struct.scm
+++ b/src/xml/rdf-struct.scm
@@ -151,7 +151,7 @@ USA.
 
 (define-guarantee rdf-bnode "RDF bnode")
 
-(set-record-type-unparser-method! <rdf-bnode>
+(define-unparser-method rdf-bnode?
   (standard-unparser-method 'RDF-BNODE
     (lambda (bnode port)
       (write-char #\space port)
@@ -225,7 +225,7 @@ USA.
     (and (not (absolute-uri? type))
 	 type)))
 
-(set-record-type-unparser-method! <rdf-literal>
+(define-unparser-method rdf-literal?
   (standard-unparser-method 'RDF-LITERAL
     (lambda (literal port)
       (write-char #\space port)
diff --git a/src/xml/xml-names.scm b/src/xml/xml-names.scm
index 72de48281..732b365c2 100644
--- a/src/xml/xml-names.scm
+++ b/src/xml/xml-names.scm
@@ -89,7 +89,7 @@ USA.
   (qname combo-name-qname)
   (expanded combo-name-expanded))
 
-(set-record-type-unparser-method! <combo-name>
+(define-unparser-method combo-name?
   (simple-unparser-method 'XML-NAME
     (lambda (name)
       (list (combo-name-qname name)))))
diff --git a/src/xml/xml-output.scm b/src/xml/xml-output.scm
index 5075a705f..1a5abe3ef 100644
--- a/src/xml/xml-output.scm
+++ b/src/xml/xml-output.scm
@@ -90,7 +90,7 @@ USA.
   (indent-attributes? ctx-indent-attributes?)
   (indent-dtd? ctx-indent-dtd?))
 
-(set-record-type-unparser-method! <ctx>
+(define-unparser-method ctx?
   (standard-unparser-method 'xml-output-context #f))
 
 (define (emit-char char ctx)
diff --git a/src/xml/xml-struct.scm b/src/xml/xml-struct.scm
index 92851f8bd..b66cd95fb 100644
--- a/src/xml/xml-struct.scm
+++ b/src/xml/xml-struct.scm
@@ -427,8 +427,8 @@ USA.
 	 (let ((name (cadr form))
 	       (accessor (caddr form)))
 	   (let ((root (symbol 'XML- name)))
-	     `(SET-RECORD-TYPE-UNPARSER-METHOD!
-	       ,(close-syntax (symbol '< root '>) environment)
+	     `(define-unparser-method
+	       ,(close-syntax (symbol root '?) environment)
 	       (SIMPLE-UNPARSER-METHOD ',root
 		 (LAMBDA (,name)
 		   (LIST (,(close-syntax accessor environment) ,name)))))))