From: Chris Hanson Date: Sat, 2 Feb 2008 05:35:33 +0000 (+0000) Subject: Change WITH-NOTIFICATION so that the port it passes to the MESSAGE is X-Git-Tag: 20090517-FFI~358 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7420f792895ffa92c72116b5c775d29de2d3484f;p=mit-scheme.git Change WITH-NOTIFICATION so that the port it passes to the MESSAGE is smart about newlines and writes the prefix correctly. Also, make the THUNK optional, and consequently WRITE-NOTIFICATION-LINE is an alias for WITH-NOTIFICATION. --- diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index 737aa93b5..3981a6946 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: make.scm,v 14.112 2008/01/30 20:02:32 cph Exp $ +$Id: make.scm,v 14.113 2008/02/02 05:35:30 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -481,6 +481,7 @@ USA. (RUNTIME STRING-INPUT) (RUNTIME STRING-OUTPUT) (RUNTIME TRUNCATED-STRING-OUTPUT) + (RUNTIME USER-INTERFACE) ;; These MUST be done before (RUNTIME PATHNAME) ;; Typically only one of them is loaded. (RUNTIME PATHNAME UNIX) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 41d115662..9367d1f3f 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.636 2008/02/02 04:28:45 cph Exp $ +$Id: runtime.pkg,v 14.637 2008/02/02 05:35:32 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -4312,7 +4312,8 @@ USA. port/gc-start) (export (runtime emacs-interface) port/read-finish - port/read-start)) + port/read-start) + (initialization (initialize-package!))) (define-package (runtime thread) (files "thread") diff --git a/v7/src/runtime/usrint.scm b/v7/src/runtime/usrint.scm index 632d588b2..337c74065 100644 --- a/v7/src/runtime/usrint.scm +++ b/v7/src/runtime/usrint.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: usrint.scm,v 1.28 2008/01/30 20:02:37 cph Exp $ +$Id: usrint.scm,v 1.29 2008/02/02 05:35:33 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -292,46 +292,102 @@ USA. ;;;; Activity notification -(define *notification-depth* 0) - -(define (with-notification message thunk) - (let ((port (notification-output-port)) - (done? #f) - (n)) - (dynamic-wind - (lambda () - (start-notification-line) - (message port) - (write-string "... " port) - (set! n (output-port/bytes-written port)) - unspecific) - (lambda () - (let ((v - (fluid-let ((*notification-depth* (+ *notification-depth* 1))) - (thunk)))) - (set! done? #t) - v)) - (lambda () - (if done? - (begin - (if (if n - (> (output-port/bytes-written port) n) - (output-port/line-start? port)) - (begin - (start-notification-line) - (write-string "... " port))) - (set! n) - (write-string "done" port) - (newline port))))))) - -(define (write-notification-line message) - (start-notification-line) - (message (notification-output-port))) - -(define (start-notification-line) +(define (with-notification message #!optional thunk) + (if (or (default-object? thunk) (not thunk)) + (message (wrapped-notification-port)) + (let ((done? #f) + (port) + (n)) + (dynamic-wind + (lambda () + (set! port (wrapped-notification-port)) + (message port) + (write-string "... " port) + (set! n (output-port/bytes-written port)) + unspecific) + (lambda () + (let ((v + (fluid-let ((*notification-depth* + (+ *notification-depth* 1))) + (thunk)))) + (set! done? #t) + v)) + (lambda () + (if done? + (begin + (if (if n + (> (output-port/bytes-written port) n) + (output-port/line-start? port)) + (begin + (newline port) + (write-string "... " port))) + (write-string "done" port) + (newline port))) + (set! port) + (set! n) + unspecific))))) + +(define (wrapped-notification-port) (let ((port (notification-output-port))) (fresh-line port) - (write-string ";" port) - (do ((i 0 (+ i 1))) - ((not (< i *notification-depth*))) - (write-string " " port)))) \ No newline at end of file + (write-notification-prefix port) + (make-port wrapped-notification-port-type port))) + +(define (make-wrapped-notification-port-type) + (make-port-type `((WRITE-CHAR ,operation/write-char) + (X-SIZE ,operation/x-size) + (COLUMN ,operation/column) + (BYTES-WRITTEN ,operation/bytes-written)) + #f)) + +(define (operation/write-char port char) + (let ((port* (port/state port))) + (let ((n (output-port/write-char port* char))) + (if (char=? char #\newline) + (write-notification-prefix port*)) + n))) + +(define (operation/x-size port) + (let ((port* (port/state port))) + (let ((op (port/operation port* 'X-SIZE))) + (and op + (let ((n (op port*))) + (and n + (max (- n (notification-prefix-length)) + 0))))))) + +(define (operation/column port) + (let ((port* (port/state port))) + (let ((op (port/operation port* 'COLUMN))) + (and op + (let ((n (op port*))) + (and n + (max (- n (notification-prefix-length)) + 0))))))) + +(define (operation/bytes-written port) + (let ((port* (port/state port))) + (let ((op (port/operation port* 'BYTES-WRITTEN))) + (and op + (op port*))))) + +(define (write-notification-prefix port) + (write-string ";" port) + (do ((i 0 (+ i 1))) + ((not (< i *notification-depth*))) + (write-string indentation-atom port))) + +(define (notification-prefix-length) + (+ 1 + (* (string-length indentation-atom) + *notification-depth*))) + +(define *notification-depth*) +(define indentation-atom) +(define wrapped-notification-port-type) + +(define (initialize-package!) + (set! *notification-depth* 0) + (set! indentation-atom " ") + (set! wrapped-notification-port-type (make-wrapped-notification-port-type)) + unspecific) \ No newline at end of file