Changeset 6194

Timestamp:

Apr 7, 2007, 8:58:42 PM (18 years ago)

Author:

Gary Byers

Message:

Per-process DRIBBLE-ing.

File:

• trunk/ccl/level-1/l1-processes.lisp (modified) (5 diffs)

trunk/ccl/level-1/l1-processes.lisp

@@ -136 +136 @@
                          :initarg :allocation-quantum
                          :reader process-allocation-quantum
-                         :type (satisfies valid-allocation-quantum-p)))
-  
+                         :type (satisfies valid-allocation-quantum-p))
+     (dribble-stream :initform nil)
+     (dribble-saved-terminal-io :initform nil))
   (:primary-p t))
 
@@ -185 +186 @@
 
 
-(defglobal *initial-process*
+(defstatic *initial-process*
     (let* ((p (make-process
                "Initial"
@@ -197 +198 @@
   "Bound in each process, to that process itself.")
 
-(defglobal *interactive-abort-process* *initial-process*)
+(defstatic *interactive-abort-process* *initial-process*)
 
 
@@ -383 +384 @@
                   (if defenv
                     (eq :global (%cdr (assq s (defenv.specials defenv)))))))
-      (error "~s not defined with ~s" s 'defglobal))
+      (error "~s not defined with ~s" s 'defstatic))
     s))
 
@@ -633 +634 @@
   (when (eq p *current-process*)
     (quit)))
+
+(defmethod process-stop-dribbling ((p process))
+  (with-slots (dribble-stream dribble-saved-terminal-io) p
+    (when dribble-stream
+      (close dribble-stream)
+      (setq dribble-stream nil))
+    (when dribble-saved-terminal-io
+      (setq *terminal-io* dribble-saved-terminal-io
+            dribble-saved-terminal-io nil))))
+
+(defmethod process-dribble ((p process) path)
+  (with-slots (dribble-stream dribble-saved-terminal-io) p
+    (process-stop-dribbling p)
+    (when path
+      (let* ((in (two-way-stream-input-stream *terminal-io*))
+             (out (two-way-stream-output-stream *terminal-io*))
+             (f (open path :direction :output :if-exists :append 
+                      :if-does-not-exist :create)))
+        (without-interrupts
+         (setq dribble-stream f
+               dribble-saved-terminal-io *terminal-io*
+               *terminal-io* (make-echoing-two-way-stream
+                              (make-echo-stream in f)
+                              (make-broadcast-stream out f)))))
+      path)))