From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 20 Nov 1997 05:27:45 +0000 (+0000)
Subject: Change interface to process-filter.
X-Git-Tag: 20090517-FFI~4927
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3fcd3998a83d9bc2fb32a2f6aa62deee3355aa89;p=mit-scheme.git

Change interface to process-filter.
---

diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index bbe4395a5..0e5d8a51a 100644
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: edwin.pkg,v 1.214 1997/11/04 11:04:52 cph Exp $
+$Id: edwin.pkg,v 1.215 1997/11/20 05:27:37 cph Exp $
 
 Copyright (c) 1989-97 Massachusetts Institute of Technology
 
@@ -904,6 +904,7 @@ MIT in each case. |#
   (parent (edwin))
   (export (edwin)
 	  accept-process-output
+	  add-process-filter
 	  buffer-default-directory
 	  buffer-processes			; always present
 	  continue-process
@@ -943,15 +944,18 @@ MIT in each case. |#
 	  process-status-changes?		; always present
 	  process-status-message
 	  quit-process
+	  remove-process-filter
+	  run-synchronous-process
 	  set-process-buffer!
 	  set-process-filter!
 	  set-process-kill-without-query!
 	  set-process-sentinel!
 	  shell-command
+	  standard-process-filter
 	  start-process
 	  stop-process
 	  subprocesses-available?		; always present
-	  run-synchronous-process))
+	  ))
 
 (os-type-case
  ((dos)
diff --git a/v7/src/edwin/process.scm b/v7/src/edwin/process.scm
index a1d229ef7..4e4049e01 100644
--- a/v7/src/edwin/process.scm
+++ b/v7/src/edwin/process.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: process.scm,v 1.52 1997/11/19 23:40:59 cph Exp $
+;;;	$Id: process.scm,v 1.53 1997/11/20 05:27:30 cph Exp $
 ;;;
 ;;;	Copyright (c) 1991-97 Massachusetts Institute of Technology
 ;;;
@@ -399,7 +399,7 @@ Initialized from the SHELL environment variable."
 	   (message-with-reason "exited abnormally" "with code")))
       ((SIGNAL) (message-with-reason "terminated by signal" false))
       (else (error "illegal process status" status)))))
-
+
 (define (output-substring process string length)
   (cond ((process-filter process)
 	 =>
@@ -413,6 +413,57 @@ Initialized from the SHELL environment variable."
 	     (set-mark-index! mark (+ index length)))
 	   true))
 	(else false)))
+
+(define (add-process-filter process filter)
+  (let ((filter* (process-filter process)))
+    (if (filter-dispatcher? filter*)
+	(add-filter-to-dispatcher filter* filter)
+	(set-process-filter! process
+			     (make-filter-dispatcher (if filter*
+							 (list filter* filter)
+							 (list filter)))))))
+
+(define (remove-process-filter process filter)
+  (set-process-filter!
+   process
+   (let ((filter* (process-filter process)))
+     (cond ((eq? filter filter*) #f)
+	   ((filter-dispatcher? filter*)
+	    (remove-filter-from-dispatcher filter* filter))
+	   (else filter*)))))
+
+(define (make-filter-dispatcher filters)
+  (make-entity filter-dispatcher-procedure filters))
+
+(define (filter-dispatcher? object)
+  (and (entity? object)
+       (eq? filter-dispatcher-procedure (entity-procedure object))))
+
+(define (filter-dispatcher-procedure dispatcher process string start end)
+  (let loop ((filters (entity-extra dispatcher)))
+    (and (not (null? filters))
+	 (or ((car filters) process string start end)
+	     (loop (cdr filters))))))
+
+(define (add-filter-to-dispatcher dispatcher filter)
+  (let ((filters (entity-extra dispatcher)))
+    (if (pair? filters)
+	(set-cdr! (last-pair filters) (list filter))
+	(set-entity-extra! dispatcher (list filter)))))
+
+(define (remove-filter-from-dispatcher dispatcher filter)
+  (let ((filters (delq! filter (entity-extra dispatcher))))
+    (set-entity-extra! dispatcher filters)
+    (and (not (null? filters))
+	 dispatcher)))
+
+(define (standard-process-filter filter)
+  (lambda (process string start end)
+    (let ((mark (process-mark process)))
+      (and mark
+	   (begin
+	     (filter mark string start end)
+	     #t)))))
 
 ;;;; Signals
 
diff --git a/v7/src/edwin/telnet.scm b/v7/src/edwin/telnet.scm
index 302deb76e..83b06c4bb 100644
--- a/v7/src/edwin/telnet.scm
+++ b/v7/src/edwin/telnet.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: telnet.scm,v 1.11 1997/11/19 23:40:53 cph Exp $
+$Id: telnet.scm,v 1.12 1997/11/20 05:27:45 cph Exp $
 
 Copyright (c) 1991-97 Massachusetts Institute of Technology
 
@@ -99,8 +99,8 @@ use it instead of the default."
 		 (make-comint mode buffer-name "telnet" host)))))
       (let ((process (get-buffer-process buffer)))
 	(if process
-	    (set-process-filter! process
-				 (make-telnet-filter process))))
+	    (add-process-filter process
+				(standard-process-filter telnet-filter))))
       (select-buffer buffer))))
 
 (define-command telnet-send-input
@@ -128,16 +128,12 @@ With prefix arg, the character is repeated that many times."
 	    ((> argument 1)
 	     (process-send-string process (make-string argument char)))))))
 
-(define (telnet-filter process string start end)
-  (let ((mark (process-mark process)))
-    (and mark
-	 (let ((index (mark-index mark))
-	       (new-string (telnet-filter-substring string start end)))
-	   (let ((new-length (string-length new-string)))
-	     (group-insert-substring! (mark-group mark) index
-				      new-string 0 new-length)
-	     (set-mark-index! mark (+ index new-length))
-	     #t)))))
+(define (telnet-filter mark string start end)
+  (let ((index (mark-index mark))
+	(new-string (telnet-filter-substring string start end)))
+    (let ((new-length (string-length new-string)))
+      (group-insert-substring! (mark-group mark) index new-string 0 new-length)
+      (set-mark-index! mark (+ index new-length)))))
 
 (define (telnet-filter-substring string start end)
   (substring-substitute string start end