From: Chris Hanson Date: Wed, 25 Oct 2006 04:25:37 +0000 (+0000) Subject: Implement WITH-NOTIFICATION to provide more uniform handling of status X-Git-Tag: 20090517-FFI~876 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=94ff67a3ddc90d57c197ae46dfe952d892ea6957;p=mit-scheme.git Implement WITH-NOTIFICATION to provide more uniform handling of status notifications, such as "Loading" messages from LOAD. --- diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm index 12d1dcefb..e0eb3a1c7 100644 --- a/v7/src/runtime/global.scm +++ b/v7/src/runtime/global.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: global.scm,v 14.74 2006/09/15 01:20:04 cph Exp $ +$Id: global.scm,v 14.75 2006/10/25 04:25:17 cph Exp $ Copyright 1988,1989,1991,1992,1993,1995 Massachusetts Institute of Technology Copyright 1998,2000,2001,2003,2004,2006 Massachusetts Institute of Technology @@ -341,37 +341,27 @@ USA. ((ucode-primitive primitive-impurify) object)) object) -(define (fasdump object filename - #!optional suppress-messages? dump-option) - (let* ((filename (->namestring (merge-pathnames filename))) - (do-it - (lambda (start-message end-message) - (start-message) - (let loop () - (if ((ucode-primitive primitive-fasdump) - object filename - (if (default-object? dump-option) - #f - dump-option)) - (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 (notification-output-port))) - (do-it (lambda () - (fresh-line port) - (write-string ";Dumping " port) - (write (enough-namestring filename) port)) - (lambda () - (write-string " -- done" port) - (newline port)))) - (do-it no-print no-print)))) +(define (fasdump object filename #!optional quiet? dump-option) + (let ((filename (->namestring (merge-pathnames filename))) + (quiet? (if (default-object? quiet?) #f quiet?)) + (dump-option (if (default-object? dump-option) #f dump-option))) + (let ((do-it + (lambda () + (let loop () + (if (not ((ucode-primitive primitive-fasdump) + object filename dump-option)) + (begin + (with-simple-restart 'RETRY "Try again." + (lambda () + (error "FASDUMP: Object is too large to be dumped:" + object))) + (loop))))))) + (if quiet? + (do-it) + (with-notification (lambda (port) + (write-string "Dumping " port) + (write (enough-namestring filename) port)) + do-it))))) ;;;; Hook lists diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm index 154e26624..fe5a623e6 100644 --- a/v7/src/runtime/load.scm +++ b/v7/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: load.scm,v 14.79 2006/10/16 06:23:45 savannah-arthur Exp $ +$Id: load.scm,v 14.80 2006/10/25 04:25:23 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1999,2000,2001,2002,2003 Massachusetts Institute of Technology @@ -375,14 +375,10 @@ USA. (define (loading-message suppress-loading-message? pathname do-it) (if suppress-loading-message? (do-it) - (let ((port (notification-output-port))) - (fresh-line port) - (write-string ";Loading " port) - (write (enough-namestring pathname) port) - (let ((value (do-it))) - (write-string " -- done" port) - (newline port) - value)))) + (with-notification (lambda (port) + (write-string "Loading " port) + (write (enough-namestring pathname) port)) + do-it))) (define *purification-root-marker*) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 3651f35f6..8d486a7e4 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.600 2006/10/25 03:15:29 cph Exp $ +$Id: runtime.pkg,v 14.601 2006/10/25 04:25:32 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology @@ -4269,7 +4269,8 @@ USA. prompt-for-command-expression prompt-for-confirmation prompt-for-evaluated-expression - prompt-for-expression) + prompt-for-expression + with-notification) (export (runtime rep) port/set-default-environment port/write-result) diff --git a/v7/src/runtime/usrint.scm b/v7/src/runtime/usrint.scm index 47e0eb28a..e4d87e813 100644 --- a/v7/src/runtime/usrint.scm +++ b/v7/src/runtime/usrint.scm @@ -1,9 +1,9 @@ #| -*-Scheme-*- -$Id: usrint.scm,v 1.21 2005/04/01 04:47:12 cph Exp $ +$Id: usrint.scm,v 1.22 2006/10/25 04:25:37 cph Exp $ Copyright 1991,1992,1993,1994,1995,2001 Massachusetts Institute of Technology -Copyright 2003,2005 Massachusetts Institute of Technology +Copyright 2003,2005,2006 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -190,7 +190,7 @@ USA. (write-string (cdr prompt) port)) (write-string prompt port)) (flush-output port))))) - + ;;;; Debugger Support (define (port/debugger-failure port message) @@ -288,3 +288,40 @@ USA. (let ((operation (port/operation port 'READ-FINISH))) (if operation (operation port)))) + +;;;; Activity notification + +(define *notification-depth* 0) + +(define (with-notification message thunk) + (let ((port (notification-output-port))) + (let ((prefix + (lambda () + (fresh-line port) + (write-string ";" port) + (do ((i 0 (+ i 1))) + ((not (< i *notification-depth*))) + (write-string " " port)) + (message port) + (write-string "... " port)))) + (prefix) + (let ((n (output-port/bytes-written port))) + (let ((p + (call-with-current-continuation + (lambda (k) + (bind-condition-handler (list condition-type:error) + (lambda (condition) + (k (cons #f condition))) + (lambda () + (fluid-let ((*notification-depth* + (+ *notification-depth* 1))) + (cons #t (thunk))))))))) + (if (if n + (> (output-port/bytes-written port) n) + (output-port/line-start? port)) + (prefix)) + (write-string (if (car p) "done" "ERROR") port) + (newline port) + (if (car p) + (cdr p) + (signal-condition (cdr p)))))))) \ No newline at end of file