From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 13 May 2018 06:19:18 +0000 (-0700)
Subject: Eliminate uses of unparser/set-tagged-{pair,vector}-unparser!.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~54
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5455ac88cf262adcff438fd204150f64f9153974;p=mit-scheme.git

Eliminate uses of unparser/set-tagged-{pair,vector}-unparser!.

Also change their implementation to use define-print-method.
---

diff --git a/src/compiler/base/object.scm b/src/compiler/base/object.scm
index ccf952481..136dc28de 100644
--- a/src/compiler/base/object.scm
+++ b/src/compiler/base/object.scm
@@ -59,7 +59,14 @@ USA.
 			       ;; Propagate this downward at construction time
 			       ;; to avoid having to crawl upward at use time.
 			       (and parent (vector-tag-noop parent)))))
-	(unparser/set-tagged-vector-method! tag tagged-vector/unparse)
+	(define-print-method (lambda (object)
+			       (and (vector? object)
+				    (fix:> (vector-length object) 0)
+				    (eq? tag (vector-ref object 0))))
+	  (lambda (vector port)
+	    (parameterize* (list (cons param:printer-radix 16))
+	      (lambda ()
+		((tagged-vector/unparser vector) vector port)))))
 	tag))))
 
 (define (define-vector-tag-unparser tag unparser)
@@ -145,9 +152,4 @@ USA.
 	((tagged-vector? object)
 	 (vector-tag-description (tagged-vector/tag object)))
 	(else
-	 (error "Not a tagged vector" object))))
-
-(define (tagged-vector/unparse state vector)
-  (parameterize* (list (cons param:printer-radix 16))
-    (lambda ()
-      ((tagged-vector/unparser vector) state vector))))
+	 (error "Not a tagged vector" object))))
\ No newline at end of file
diff --git a/src/edwin/window.scm b/src/edwin/window.scm
index 84f744d0f..e39fdac86 100644
--- a/src/edwin/window.scm
+++ b/src/edwin/window.scm
@@ -334,7 +334,12 @@ USA.
 ;;;; Inferiors
 
 (define %inferior-tag
-  "inferior")
+  '|#[(edwin window) inferior]|)
+
+(define (%inferior? object)
+  (and (vector? object)
+       (fix:= 5 (vector-length object))
+       (eq? %inferior-tag (vector-ref object 0))))
 
 (define-integrable (%make-inferior window x-start y-start redisplay-flags)
   (vector %inferior-tag window x-start y-start redisplay-flags))
@@ -363,8 +368,8 @@ USA.
 (define-integrable (set-inferior-redisplay-flags! inferior redisplay-flags)
   (vector-set! inferior 4 redisplay-flags))
 
-(unparser/set-tagged-vector-method! %inferior-tag
-  (bracketed-print-method 'INFERIOR
+(define-print-method %inferior?
+  (bracketed-print-method 'inferior
     (lambda (inferior port)
       (write-string " " port)
       (write (inferior-window inferior) port)
diff --git a/src/runtime/dos-pathname.scm b/src/runtime/dos-pathname.scm
index 7e8351466..b26c33e97 100644
--- a/src/runtime/dos-pathname.scm
+++ b/src/runtime/dos-pathname.scm
@@ -198,7 +198,7 @@ USA.
   (string-append (print-device (%pathname-device pathname))
 		 (print-directory (%pathname-directory pathname))
 		 (print-name (%pathname-name pathname)
-			       (%pathname-type pathname))))
+			     (%pathname-type pathname))))
 
 (define (print-device device)
   (if (or (not device) (eq? device 'unspecific))
diff --git a/src/runtime/gdatab.scm b/src/runtime/gdatab.scm
index bd45765e3..1b02f2aac 100644
--- a/src/runtime/gdatab.scm
+++ b/src/runtime/gdatab.scm
@@ -28,56 +28,27 @@ USA.
 ;;; package: (runtime global-database)
 
 (declare (usual-integrations))
-
-(define (initialize-package!)
-  (set! event:after-restore (make-event-distributor))
-  (set! event:after-restart (make-event-distributor))
-  (set! event:before-exit (make-event-distributor))
-  (set! tagged-pair-methods (make-1d-table))
-  (set! tagged-vector-methods (make-1d-table))
-  (set! named-structure-descriptions (make-1d-table))
-  unspecific)
 
-(define event:after-restore)
-(define event:after-restart)
-(define event:before-exit)
-(define tagged-pair-methods)
-(define tagged-vector-methods)
-(define named-structure-descriptions)
-
-(define (unparser/tagged-pair-method tag)
-  (1d-table/get tagged-pair-methods tag #f))
+(define-deferred event:after-restore (make-event-distributor))
+(define-deferred event:after-restart (make-event-distributor))
+(define-deferred event:before-exit (make-event-distributor))
+(define-deferred named-structure-descriptions (make-1d-table))
 
 (define (unparser/set-tagged-pair-method! tag method)
-  (1d-table/put! tagged-pair-methods tag method))
-
-(define (unparser/tagged-vector-method tag)
-  (1d-table/get tagged-vector-methods tag #f))
+  (define-print-method (lambda (object)
+			 (and (pair? object)
+			      (eq? tag (car object))))
+    method))
 
 (define (unparser/set-tagged-vector-method! tag method)
-  (1d-table/put! tagged-vector-methods tag method))
+  (define-print-method (lambda (object)
+			 (and (vector? object)
+			      (fix:> (vector-length object) 0)
+			      (eq? tag (vector-ref object 0))))
+    method))
 
 (define (named-structure/get-tag-description tag)
   (1d-table/get named-structure-descriptions tag #f))
 
 (define (named-structure/set-tag-description! tag description)
-  (1d-table/put! named-structure-descriptions tag description))
-
-;;; Support for old-style methods
-
-(define (add-unparser-special-pair! tag method)
-  (unparser/set-tagged-pair-method! tag (convert-old-method method)))
-
-(define (add-unparser-special-object! tag method)
-  (unparser/set-tagged-vector-method! tag (convert-old-method method)))
-
-(define (unparse-with-brackets thunk)
-  (write-string "#[")
-  (thunk)
-  (write-char #\]))
-
-(define (convert-old-method method)
-  (lambda (state object)
-    (parameterize* (list (cons current-output-port (unparser-state/port state)))
-      (lambda ()
-	(method object)))))
\ No newline at end of file
+  (1d-table/put! named-structure-descriptions tag description))
\ No newline at end of file
diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 777fa4300..6b6a5cdc4 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -416,8 +416,6 @@ USA.
   (package-initialize '(runtime thread) 'initialize-low! #t) ;First 1d-table.
   (package-initialize '(runtime event-distributor) #f #t)
   (package-initialize '(runtime global-database) #f #t)
-  (package-initialize '(runtime population) 'initialize-unparser! #t)
-  (package-initialize '(runtime 1d-property) 'initialize-unparser! #t)
   (package-initialize '(runtime gc-finalizer) #f #t)
 
   ;; Load everything else.
diff --git a/src/runtime/poplat.scm b/src/runtime/poplat.scm
index f1d233a33..4fd6b36c6 100644
--- a/src/runtime/poplat.scm
+++ b/src/runtime/poplat.scm
@@ -32,16 +32,18 @@ USA.
 ;;; A population is a weak collection of objects.  A serial
 ;;; population is a population with a mutex to serialize its operations.
 
-(define (initialize-package!)
-  (set! population-of-populations (list population-tag (make-thread-mutex)))
-  (add-secondary-gc-daemon!/unsafe clean-all-populations!))
+(define-deferred population-of-populations
+  (list population-tag (make-thread-mutex)))
 
-(define (initialize-unparser!)
-  (unparser/set-tagged-pair-method! population-tag
-				    (standard-print-method 'population)))
+(add-boot-init!
+ (lambda ()
+   (add-secondary-gc-daemon!/unsafe clean-all-populations!)))
 
-(define bogus-false '(bogus-false))
-(define population-tag '(population))
+(define-integrable population-tag
+  '|#[population]|)
+
+(define-integrable bogus-false
+  '|#[population false]|)
 
 (define-integrable (canonicalize object)
   (if (eq? object false) bogus-false object))
@@ -67,8 +69,6 @@ USA.
 (define (clean-all-populations!)
   (clean-population! population-of-populations)
   (map-over-population! population-of-populations clean-population!))
-
-(define population-of-populations)
 
 (define (make-population)
   (let ((population (list population-tag #f)))
@@ -94,6 +94,9 @@ USA.
   (and (pair? object)
        (eq? (car object) population-tag)))
 
+(define-print-method population?
+  (standard-print-method 'population))
+
 (define-guarantee population "population")
 
 (define (add-to-population! population object)
diff --git a/src/runtime/printer.scm b/src/runtime/printer.scm
index 79a1e62b9..6e119dc78 100644
--- a/src/runtime/printer.scm
+++ b/src/runtime/printer.scm
@@ -413,7 +413,7 @@ USA.
 	  (if (string? name)
 	      (*print-string name context*)
 	      (print-object name context*))
-		(*print-char #\space context*)
+	  (*print-char #\space context*)
 	  (*print-hash object context*)
 	  (cond (procedure
 		 (procedure context*))
diff --git a/src/runtime/prop1d.scm b/src/runtime/prop1d.scm
index 24a2301e3..8d77bd28c 100644
--- a/src/runtime/prop1d.scm
+++ b/src/runtime/prop1d.scm
@@ -29,15 +29,12 @@ USA.
 
 (declare (usual-integrations))
 
-(define (initialize-package!)
-  (set! population-of-1d-tables (make-serial-population/unsafe))
-  (add-secondary-gc-daemon!/unsafe clean-1d-tables!))
+(define-deferred population-of-1d-tables
+  (make-serial-population/unsafe))
 
-(define (initialize-unparser!)
-  (unparser/set-tagged-pair-method! 1d-table-tag
-				    (standard-print-method '1d-table)))
-
-(define population-of-1d-tables)
+(add-boot-init!
+ (lambda ()
+   (add-secondary-gc-daemon!/unsafe clean-1d-tables!)))
 
 (define (clean-1d-tables!)
   (for-each-inhabitant population-of-1d-tables 1d-table/clean!))
@@ -56,11 +53,14 @@ USA.
   (and (pair? object)
        (eq? (car object) 1d-table-tag)))
 
-(define 1d-table-tag
-  "1D table")
+(define-integrable 1d-table-tag
+  '|#[1D table]|)
+
+(define-integrable false-key
+  '|#[1D table false]|)
 
-(define false-key
-  "false key")
+(define-print-method 1d-table?
+  (standard-print-method '1d-table))
 
 (define-integrable (weak-cons car cdr)
   (system-pair-cons (ucode-type weak-cons) car cdr))
diff --git a/src/runtime/random.scm b/src/runtime/random.scm
index 53eaa71be..428b221f3 100644
--- a/src/runtime/random.scm
+++ b/src/runtime/random.scm
@@ -337,10 +337,14 @@ USA.
   (and (vector? object)
        (fix:= (vector-length object) 4)
        (eq? (vector-ref object 0) random-state-tag)))
+(register-predicate! random-state? 'random-state '<= vector?)
 
 (define-integrable random-state-tag
   '|#[(runtime random-number)random-state]|)
 
+(define-print-method random-state?
+  (standard-print-method 'random-state))
+
 (define-integrable (random-state-index s) (vector-ref s 1))
 (define-integrable (set-random-state-index! s x) (vector-set! s 1 x))
 
@@ -416,6 +420,6 @@ USA.
 				'#(index borrow vector)
 				'#(1 2 3)
 				(make-vector 3 (lambda () #f))
-				(standard-print-method 'random-state)
+				#f
 				random-state-tag
 				4)))
\ No newline at end of file
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index cd69f2b5b..9373dae61 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1211,8 +1211,7 @@ USA.
 	  make-serial-population/unsafe
 	  add-to-population!/unsafe)
   (import (runtime gc-daemons)
-	  add-secondary-gc-daemon!/unsafe)
-  (initialization (initialize-package!)))
+	  add-secondary-gc-daemon!/unsafe))
 
 (define-package (runtime 2d-property)
   (files "prop2d")
@@ -2360,20 +2359,16 @@ USA.
 (define-package (runtime global-database)
   (files "gdatab")
   (parent (runtime))
+  (export () deprecated:global-database
+	  unparser/set-tagged-pair-method!
+	  unparser/set-tagged-vector-method!)
   (export ()
-	  add-unparser-special-object!
-	  add-unparser-special-pair!
 	  event:after-restart
 	  event:after-restore
 	  event:before-exit
-	  named-structure/get-tag-description
-	  named-structure/set-tag-description!
-	  unparse-with-brackets
-	  unparser/set-tagged-pair-method!
-	  unparser/set-tagged-vector-method!
-	  unparser/tagged-pair-method
-	  unparser/tagged-vector-method)
-  (initialization (initialize-package!)))
+	  named-structure/set-tag-description!)
+  (export (runtime record)
+	  named-structure/get-tag-description))
 
 (define-package (runtime hash)
   (files "hash")
@@ -2400,7 +2395,8 @@ USA.
   (export () deprecated:hash-table
 	  (eq-hash-table-type key-weak-eq-hash-table-type)
 	  (eqv-hash-table-type key-weak-eqv-hash-table-type)
-	  (hash-table-entry-type:key/datum-weak hash-table-entry-type:key&datum-weak)
+	  (hash-table-entry-type:key/datum-weak
+	   hash-table-entry-type:key&datum-weak)
 	  (hash-table/clean! hash-table-clean!)
 	  (hash-table/clear! hash-table-clear!)
 	  (hash-table/count hash-table-size)
@@ -3525,8 +3521,7 @@ USA.
 	  map-over-population
 	  map-over-population!
 	  population?
-	  remove-from-population!)
-  (initialization (initialize-package!)))
+	  remove-from-population!))
 
 (define-package (runtime pretty-printer)
   (files "pp")
diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 6f0297ca0..774780f27 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -136,7 +136,7 @@ USA.
 				'#(waiting-threads owner)
 				'#(1 2)
 				(vector 2 (lambda () #f))
-				(standard-print-method 'thread-mutex)
+				#f
 				thread-mutex-tag
 				3))
   (named-structure/set-tag-description! link-tag
@@ -145,10 +145,13 @@ USA.
 				'#(prev next item)
 				'#(1 2 3)
 				(vector 3 (lambda () #f))
-				(standard-print-method 'link)
+				#f
 				link-tag
 				4)))
 
+(define-print-method link?
+  (standard-print-method 'link))
+
 (define (reset-threads!)
   (reset-threads-low!)
   (reset-threads-high!))
@@ -1159,6 +1162,9 @@ USA.
   (waiting-threads (make-ring) read-only #t)
   (owner #f))
 
+(define-print-method thread-mutex?
+  (standard-print-method 'thread-mutex))
+
 (define-integrable (guarantee-thread-mutex mutex procedure)
   (if (not (thread-mutex? mutex))
       (error:wrong-type-argument mutex "thread-mutex" procedure)))
diff --git a/src/runtime/unix-pathname.scm b/src/runtime/unix-pathname.scm
index 001a6ebc9..7edb8c064 100644
--- a/src/runtime/unix-pathname.scm
+++ b/src/runtime/unix-pathname.scm
@@ -157,7 +157,7 @@ USA.
 (define (unix/pathname->namestring pathname)
   (string-append (print-directory (%pathname-directory pathname))
 		 (print-name (%pathname-name pathname)
-			       (%pathname-type pathname))))
+			     (%pathname-type pathname))))
 
 (define (print-directory directory)
   (cond ((not directory)
diff --git a/src/sf/pthmap.scm b/src/sf/pthmap.scm
index 15aa9e15c..ae965e36f 100644
--- a/src/sf/pthmap.scm
+++ b/src/sf/pthmap.scm
@@ -39,10 +39,6 @@ USA.
 (define pathname-map/tag "pathname-map")
 (define pathname-map/root-node cdr)
 
-(unparser/set-tagged-pair-method!
- pathname-map/tag
- (standard-print-method "PATHNAME-MAP"))
-
 (declare (integrate-operator node/make))
 
 (define (node/make)
@@ -107,6 +103,9 @@ USA.
     (and (pair? object)
 	 (eq? (car object) pathname-map/tag))))
 
+(define-print-method pathname-map?
+  (standard-print-method 'pathname-map))
+
 (set! pathname-map/lookup
   (named-lambda (pathname-map/lookup map pathname if-found if-not)
     (let ((node