From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Sat, 18 Jul 2015 23:37:19 +0000 (-0700)
Subject: Add copy-select-registry!.
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2b8bc23cad1075076299c3580d6fc5b541d4c129;p=mit-scheme.git

Add copy-select-registry!.
---

diff --git a/src/runtime/io.scm b/src/runtime/io.scm
index c7fc931d1..523bc1aaf 100644
--- a/src/runtime/io.scm
+++ b/src/runtime/io.scm
@@ -522,6 +522,14 @@ USA.
    descriptor
    (encode-select-registry-mode mode))
   (set-select-registry-length! registry #f))
+
+(define (get-select-registry-length registry)
+  (or (select-registry-length registry)
+      (let ((rl
+	     ((ucode-primitive select-registry-length 1)
+	      (select-registry-handle registry))))
+	(set-select-registry-length! registry rl)
+	rl)))
 
 (define (test-for-io-on-channel channel mode #!optional block?)
   (test-for-io-on-descriptor (channel-descriptor-for-select channel)
@@ -628,13 +636,7 @@ USA.
 
 (define (allocate-select-registry-result-vectors registry)
   (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
-    (let ((n
-	   (or (select-registry-length registry)
-	       (let ((rl
-		      ((ucode-primitive select-registry-length 1)
-		       (select-registry-handle registry))))
-		 (set-select-registry-length! registry rl)
-		 rl))))
+    (let ((n (get-select-registry-length registry)))
       (let loop ((rv select-registry-result-vectors))
 	(if (pair? rv)
 	    (let ((vfd (caar rv))
@@ -665,6 +667,12 @@ USA.
 	  (set! select-registry-result-vectors
 		(cons (cons vfd vmode) select-registry-result-vectors))))
     (set-interrupt-enables! interrupt-mask)))
+
+(define (copy-select-registry! from to)
+  ((ucode-primitive copy-select-registry 2)
+   (select-registry-handle from)
+   (select-registry-handle to))
+  (set-select-registry-length! to (get-select-registry-length from)))
 
 ;;;; Interface to dynamic loader
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 5435bee1d..e9215e2f6 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3336,6 +3336,7 @@ USA.
 	  have-select?)
   (export (runtime thread)
 	  add-to-select-registry!
+	  copy-select-registry!
 	  have-select?
 	  make-select-registry
 	  remove-from-select-registry!