added dfishers steal-port stuff

scheme/rts/port.scm

@@ -6,11 +6,18 @@
 ; port handlers, and so forth.
 
 (define-record-type port-handler :port-handler
-  (make-port-handler discloser close buffer-proc)
+  (really-make-port-handler discloser close buffer-proc steal)
   port-handler?
   (discloser   port-handler-discloser)
   (close       port-handler-close)
-  (buffer-proc port-handler-buffer-proc))
+  (buffer-proc port-handler-buffer-proc)
+  (steal       port-handler-steal))
+
+(define (make-port-handler discloser close buffer-proc . maybe-steal)
+  (if (pair? maybe-steal)
+      (really-make-port-handler discloser close buffer-proc (car maybe-steal))
+      (really-make-port-handler discloser close buffer-proc
+				(lambda (port-data owner) #f))))
 
 (define (disclose-port port)
   ((port-handler-discloser (port-handler port)) (port-data port)))
@@ -495,7 +502,9 @@
    (lambda (ignore)
      (unspecific))
    (lambda (channel buffer start need)
-     (unspecific))))
+     (unspecific))
+   (lambda (ignore1 ignore2)
+     #f)))
 
 (define (make-null-output-port)
   (make-port null-output-port-handler
@@ -600,4 +609,50 @@
 	   "error when closing port"
 	   port))))
 	
+(define (steal-port! port)
+  (begin
+    (disable-interrupts!)
+    (let ((owner (if (lock-owner-uid (port-lock port))
+		     (thread-uid->thread (lock-owner-uid (port-lock port)))
+		     #f)))
+      (if (and owner
+	       (not (running? owner)))
+	  (begin
+;	    (message (list  (thread-uid owner) " "
+;			    (thread-uid (current-thread)) " "))
+	    (really-steal-port! port owner)))
+      (enable-interrupts!))))
+
+(define (really-steal-port! port owner)
+  (let ((lock (port-lock port))
+	(buffer (port-buffer port))
+	(index (port-index port))
+	(limit (port-limit port))
+	(eof? (port-pending-eof? port))
+	(status ((port-handler-steal (port-handler port))
+		 (port-data port) owner)))
+    (set-port-buffer! port (make-code-vector (code-vector-length buffer) 0))
+    (set-port-index! port 0)
+    (set-port-limit! port (if (input-port? port) 0 (code-vector-length buffer)))
+    (set-port-pending-eof?! port #f)
+    (set-port-locked?! port #f)
+    (set-port-lock! port (make-lock))
+    (interrupt-thread owner
+		      (lambda results
+			(obtain-port-lock port)
+			(cond ((output-port? port)
+			       (really-force-output port))
+			      ((< (port-index port)
+				  (port-limit port))
+			       (warn "dropping input from port" port)))
+			(set-port-buffer! port buffer)
+			(set-port-index! port index)
+			(set-port-limit! port limit)
+			(set-port-pending-eof?! port eof?)
+			(set-port-lock! port lock)
+			(or status (apply values results))))
+    ; if we took OWNER off a channel-wait queue we need to make it ready to run
+    (if status (make-ready owner))))
+			       
+