Change unparsing of compiled procedures and entries to more clearly

indicate when the source file is shown.

diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm
index 81302b3c5d956a99874d864f58704276ffd08a16..9c710322c70cebb3028ac3e97814794d66dcf009 100644 (file)
--- 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)))))
-
 \f
 ;;;; 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))))
 \f
 ;;;; Miscellaneous
+
 (define (unparse/environment environment)
   (if (lexical-unreferenceable? environment ':PRINT-SELF)
       (unparse/default environment)