From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Tue, 5 Jun 2018 08:15:36 +0000 (-0700)
Subject: world-report: Display thread names instead of associated "flags".
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~6^2~9
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d9ffdc33878ee83ae9e3e84e8447c70865d50d1c;p=mit-scheme.git

world-report: Display thread names instead of associated "flags".
---

diff --git a/src/runtime/world-report.scm b/src/runtime/world-report.scm
index dbeb62fa0..33d1d4625 100644
--- a/src/runtime/world-report.scm
+++ b/src/runtime/world-report.scm
@@ -29,15 +29,11 @@ USA.
 
 (declare (usual-integrations))
 
-(define (world-report #!optional port thread-flags)
+(define (world-report #!optional port)
   (let ((port
 	 (if (default-object? port)
 	     (current-output-port)
 	     (guarantee textual-output-port? port 'world-report)))
-	(flags (cons (cons (console-thread) "console")
-		     (if (default-object? thread-flags)
-			 '()
-			 thread-flags)))
 	(now (get-universal-time))
 	(cpu (process-time-clock)))
     (write-string "-*-Outline-*-" port)
@@ -54,7 +50,7 @@ USA.
     (write-time-interval (- now time-world-restored) port)
     (newline port)
     (memory-report port)
-    (thread-report flags port)))
+    (thread-report port)))
 
 (define (ticks->string ticks)
   (parameterize* (list (cons param:flonum-printer-cutoff '(absolute 3)))
@@ -142,7 +138,7 @@ USA.
 	      (write-char #\- port)
 	      (loop (1+ n))))))))
 
-(define (thread-report flags port)
+(define (thread-report port)
   (newline port)
   (write-string "* Threads" port)
   (newline port)
@@ -158,17 +154,11 @@ USA.
 	(write-string " CPU, " port)
 	(write-time (thread/real-time thread) port)
 	(write-string " real" port)
-	(for-each
-	  (lambda (name)
-	    (write-string ", " port)
-	    (write-string name port))
-	  (append-map! (lambda (item)
-			 (if (and (pair? item)
-				  (string? (cdr item))
-				  (eq? thread (car item)))
-			     (list (cdr item))
-			     '()))
-		       flags))
+	(let ((name (thread-get thread 'name)))
+	  (if name
+	      (begin
+		(write-char #\space port)
+		(write name port))))
 	(newline port)))
     (sort (map (lambda (t) (cons (hash-object t) t)) (threads-list))
 	  (lambda (a b) (< (car a) (car b))))))