Made FASDUMP not print if necessary.

diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm
index 7707e9435cc6ffe457cf9ae276789d5dee2023bc..3614a9fb78d2352b0ff50533a6a0a74e7caf3a85 100644 (file)
--- a/v7/src/runtime/global.scm
+++ b/v7/src/runtime/global.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.36 1992/05/10 13:36:29 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.37 1992/05/26 19:34:04 mhwu Exp $
 
 Copyright (c) 1988-92 Massachusetts Institute of Technology
 
@@ -235,20 +235,31 @@ MIT in each case. |#
       ((ucode-primitive primitive-impurify) object))
   object)
 
-(define (fasdump object filename)
-  (let ((filename (->namestring (merge-pathnames filename)))
-       (port (nearest-cmdl/port)))
-    (let loop ()
-      (fresh-line port)
-      (write-string ";Dumping " port)
-      (write (enough-namestring filename) port)
-      (if ((ucode-primitive primitive-fasdump) object filename false)
-         (write-string " -- done" port)
-         (begin
-           (with-simple-restart 'RETRY "Try again."
-             (lambda ()
-               (error "FASDUMP: Object is too large to be dumped:" object)))
-           (loop))))))
+(define (fasdump object filename #!optional suppress-messages?)
+  (let* ((filename (->namestring (merge-pathnames filename)))
+        (do-it
+         (lambda (start-message end-message)
+           (start-message)
+           (let loop ()
+             (if ((ucode-primitive primitive-fasdump) object filename false)
+                 (end-message)
+                 (begin
+                   (with-simple-restart 'RETRY "Try again."
+                     (lambda ()
+                       (error "FASDUMP: Object is too large to be dumped:"
+                              object)))
+                   (loop))))))
+        (no-print (lambda () unspecific)))
+    (if (or (default-object? suppress-messages?)
+           (not suppress-messages?))
+       (let ((port (nearest-cmdl/port)))
+         (do-it (lambda ()
+                  (fresh-line port)
+                  (write-string ";Dumping " port)
+                  (write (enough-namestring filename) port))
+                (lambda ()
+                  (write-string " -- done" port))))
+       (do-it no-print no-print))))
 
 (define (undefined-value? object)
   ;; Note: the unparser takes advantage of the fact that objects

diff --git a/v7/src/runtime/infutl.scm b/v7/src/runtime/infutl.scm
index 4b9cae1a97140c4f12adef5d2af62601d2d1690a..17a31afcc6f6e1d8feece7b47a425993f89e7cd6 100644 (file)
--- a/v7/src/runtime/infutl.scm
+++ b/v7/src/runtime/infutl.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.28 1992/05/26 18:43:40 mhwu Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.29 1992/05/26 19:36:08 mhwu Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -408,15 +408,15 @@ MIT in each case. |#
     (cond ((dbg-info? binf)
           (let ((labels (dbg-info/labels/desc binf)))
             (set-dbg-info/labels/desc! binf bsmname)
-            (fasdump binf bifpath)
-            (fasdump labels bsmpath)))
+            (fasdump binf bifpath true)
+            (fasdump labels bsmpath true)))
          ((vector? binf)
           (let ((bsm (make-vector (vector-length binf))))
             (let loop ((pos 0))
               (if (fix:= pos (vector-length bsm))
                   (begin
-                    (fasdump bsm bsmpath)
-                    (fasdump binf bifpath))
+                    (fasdump bsm bsmpath true)
+                    (fasdump binf bifpath true))
                   (let ((dbg-info (vector-ref binf pos)))
                     (let ((labels (dbg-info/labels/desc dbg-info)))
                       (vector-set! bsm pos labels)

diff --git a/v8/src/runtime/global.scm b/v8/src/runtime/global.scm
index afc34fd7120a0eca594948adcf6a078f9f8d028d..44861dc1e4f07a70dd49bb381eae29ae7e5aabca 100644 (file)
--- a/v8/src/runtime/global.scm
+++ b/v8/src/runtime/global.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.36 1992/05/10 13:36:29 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.37 1992/05/26 19:34:04 mhwu Exp $
 
 Copyright (c) 1988-92 Massachusetts Institute of Technology
 
@@ -235,20 +235,31 @@ MIT in each case. |#
       ((ucode-primitive primitive-impurify) object))
   object)
 
-(define (fasdump object filename)
-  (let ((filename (->namestring (merge-pathnames filename)))
-       (port (nearest-cmdl/port)))
-    (let loop ()
-      (fresh-line port)
-      (write-string ";Dumping " port)
-      (write (enough-namestring filename) port)
-      (if ((ucode-primitive primitive-fasdump) object filename false)
-         (write-string " -- done" port)
-         (begin
-           (with-simple-restart 'RETRY "Try again."
-             (lambda ()
-               (error "FASDUMP: Object is too large to be dumped:" object)))
-           (loop))))))
+(define (fasdump object filename #!optional suppress-messages?)
+  (let* ((filename (->namestring (merge-pathnames filename)))
+        (do-it
+         (lambda (start-message end-message)
+           (start-message)
+           (let loop ()
+             (if ((ucode-primitive primitive-fasdump) object filename false)
+                 (end-message)
+                 (begin
+                   (with-simple-restart 'RETRY "Try again."
+                     (lambda ()
+                       (error "FASDUMP: Object is too large to be dumped:"
+                              object)))
+                   (loop))))))
+        (no-print (lambda () unspecific)))
+    (if (or (default-object? suppress-messages?)
+           (not suppress-messages?))
+       (let ((port (nearest-cmdl/port)))
+         (do-it (lambda ()
+                  (fresh-line port)
+                  (write-string ";Dumping " port)
+                  (write (enough-namestring filename) port))
+                (lambda ()
+                  (write-string " -- done" port))))
+       (do-it no-print no-print))))
 
 (define (undefined-value? object)
   ;; Note: the unparser takes advantage of the fact that objects

diff --git a/v8/src/runtime/infutl.scm b/v8/src/runtime/infutl.scm
index 6119d1741a616ccb93fb643b78dac2db24eb5693..124b18c175ec5a6bd3e55562d9fabdd97d000c53 100644 (file)
--- a/v8/src/runtime/infutl.scm
+++ b/v8/src/runtime/infutl.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.28 1992/05/26 18:43:40 mhwu Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.29 1992/05/26 19:36:08 mhwu Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -408,15 +408,15 @@ MIT in each case. |#
     (cond ((dbg-info? binf)
           (let ((labels (dbg-info/labels/desc binf)))
             (set-dbg-info/labels/desc! binf bsmname)
-            (fasdump binf bifpath)
-            (fasdump labels bsmpath)))
+            (fasdump binf bifpath true)
+            (fasdump labels bsmpath true)))
          ((vector? binf)
           (let ((bsm (make-vector (vector-length binf))))
             (let loop ((pos 0))
               (if (fix:= pos (vector-length bsm))
                   (begin
-                    (fasdump bsm bsmpath)
-                    (fasdump binf bifpath))
+                    (fasdump bsm bsmpath true)
+                    (fasdump binf bifpath true))
                   (let ((dbg-info (vector-ref binf pos)))
                     (let ((labels (dbg-info/labels/desc dbg-info)))
                       (vector-set! bsm pos labels)