From 0b6e7a92404b9aa3817e4b4eef7655a300391bb4 Mon Sep 17 00:00:00 2001 From: "Henry M. Wu" Date: Tue, 26 May 1992 19:36:08 +0000 Subject: [PATCH] Made FASDUMP not print if necessary. --- v7/src/runtime/global.scm | 41 +++++++++++++++++++++++++-------------- v7/src/runtime/infutl.scm | 10 +++++----- v8/src/runtime/global.scm | 41 +++++++++++++++++++++++++-------------- v8/src/runtime/infutl.scm | 10 +++++----- 4 files changed, 62 insertions(+), 40 deletions(-) diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm index 7707e9435..3614a9fb7 100644 --- 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 4b9cae1a9..17a31afcc 100644 --- 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 afc34fd71..44861dc1e 100644 --- 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 6119d1741..124b18c17 100644 --- 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) -- 2.25.1