From b8a0e8b9969bb6276309d5b510c6ef1575b3e043 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 7 Jul 1988 16:14:39 +0000
Subject: [PATCH] Change unparsing of compiled procedures and entries to more
 clearly indicate when the source file is shown.

---
 v7/src/runtime/unpars.scm | 130 ++++++++++++++++----------------------
 1 file changed, 56 insertions(+), 74 deletions(-)

diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm
index 81302b3c5..9c710322c 100644
--- a/v7/src/runtime/unpars.scm
+++ b/v7/src/runtime/unpars.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 14.2 1988/06/15 18:35:33 jrm Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 14.3 1988/07/07 16:14:39 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -418,15 +418,8 @@ MIT in each case. |#
   (*unparse-with-brackets 'PRIMITIVE-PROCEDURE false
     (lambda ()
       (*unparse-object (primitive-procedure-name procedure)))))
-
 
 ;;;; Compiled entries
-#|
-(define (unparse/compiled-entry entry)
-  (*unparse-with-brackets (compiled-entry-type entry)
-			  false
-			  (lambda () (*unparse-datum entry))))
-|#
 
 (define (unparse/compiled-entry entry)
   (discriminate-compiled-entry entry
@@ -435,81 +428,70 @@ MIT in each case. |#
     (lambda () (unparse-compiled-entry entry))
     (lambda () (unparse-compiled-entry entry))))
 
-(define (entry-to-manifest-closure? entry)
-  (compiled-code-block/manifest-closure? 
-   (compiled-code-address->block entry)))
-
 (define (unparse-compiled-procedure entry)
-  ;; Gross-out to make the "FASLoading" message not print out
-  ;; in the middle of the other stuff.
-  (define (do-it thunk)
-    (*unparse-with-brackets
-     (if (entry-to-manifest-closure? entry)
-	 'MANIFEST-CLOSURE
-	 'COMPILED-PROCEDURE)
-     entry
-     thunk))
-  (compiled-entry->name entry
-    (lambda (string)
-      (do-it
-       (lambda () 
-	 (unparse-entry-name string))))
-    (lambda ()
-      (compiled-entry->pathname entry
-        (lambda (pathname)
-	  (do-it 
-	   (lambda () 
-	     (*unparse-string "from ")
-	     (*unparse-string (pathname-name pathname)))))
-	(lambda ()
-	  (do-it
-	   (lambda () 
-	     (*unparse-datum entry))))))))
-
-;;; Names in the symbol table are of the form
-;;; "FOOBAR-127"
-;;; The 127 is added by the compiler.  This procedure strips
-;;; the trailing number and passes the two strings to IF-STRIPPED
-;;; If the entry doesn't have a trailing number, it passes the
-;;; whole thing to IF-NOT-STRIPPED.
-;;; This will fail gracefully should the compiler change.
-
-(define (strip-trailing-number string if-stripped if-not-stripped)
+  ;; Gross-out to make the "FASLoading" message not print out in the
+  ;; middle of the other stuff.
+  (let ((unparse-it
+	 (lambda (thunk)
+	   (*unparse-with-brackets (compiled-procedure-type entry)
+				   entry
+				   thunk))))
+    (compiled-entry->name entry
+      (lambda (string)
+	(unparse-it
+	 (lambda ()
+	   (*unparse-string (detach-suffix-number string)))))
+      (lambda ()
+	(compiled-entry->pathname entry
+	  (lambda (pathname)
+	    (unparse-it 
+	     (lambda () 
+	       (*unparse-string "from file ")
+	       (*unparse-object (pathname-name pathname)))))
+	  (lambda ()
+	    (unparse-it
+	     (lambda () 
+	       (*unparse-datum entry)))))))))
+
+(define (compiled-procedure-type entry)
+  (if (compiled-code-block/manifest-closure?
+       (compiled-code-address->block entry))
+      'MANIFEST-CLOSURE
+      'COMPILED-PROCEDURE))
+
+(define (unparse-compiled-entry entry)
+  (let ((unparse-it
+	 (lambda (thunk)
+	   (*unparse-with-brackets (compiled-entry-type entry) entry thunk))))
+    (compiled-entry->pathname entry
+      (lambda (pathname)
+	(unparse-it 
+	 (lambda ()
+	   (*unparse-string "from file ")
+	   (*unparse-object (pathname-name pathname)))))
+      (lambda () 
+	(unparse-it 
+	 (lambda () (*unparse-datum entry)))))))
+
+;;; Names in the symbol table are of the form "FOOBAR-127".  The 127
+;;; is added by the compiler.  This procedure detaches the suffix
+;;; number from the prefix name.  It does nothing if there is no
+;;; numeric suffix.
+
+(define (detach-suffix-number string)
   (let loop ((index (-1+ (string-length string))))
-    (cond ((zero? index) (if-not-stripped))
+    (cond ((zero? index) string)
 	  ((char=? (string-ref string index) #\-)
-	   (if-stripped 
+	   (string-append
 	    (substring string 0 index)
+	    " "
 	    (substring string (1+ index) (string-length string))))
 	  ((char-numeric? (string-ref string index))
 	   (loop (-1+ index)))
-	  (else (if-not-stripped)))))
-
-(define (unparse-entry-name string)
-  (strip-trailing-number string
-    (lambda (string1 string2)
-      (*unparse-string string1)
-      (*unparse-string " ")
-      (*unparse-string string2))
-    *unparse-string))
-
-(define (unparse-compiled-entry entry)
-  (define (unparse-it thunk)
-    (*unparse-with-brackets
-     (compiled-entry-type entry)
-     entry
-     (lambda () (thunk))))
-  (compiled-entry->pathname entry
-    (lambda (pathname)
-      (unparse-it 
-       (lambda ()
-	 (*unparse-string "from ")
-	 (*unparse-string (pathname-name pathname)))))
-    (lambda () 
-      (unparse-it 
-       (lambda () (*unparse-datum entry))))))
+	  (else string))))
 
 ;;;; Miscellaneous
+
 (define (unparse/environment environment)
   (if (lexical-unreferenceable? environment ':PRINT-SELF)
       (unparse/default environment)
-- 
2.25.1