From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Mon, 4 Jan 2016 02:21:56 +0000 (-0700)
Subject: Merge branch 'master' into Gtk.
X-Git-Tag: mit-scheme-pucked-9.2.12~390
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6ea686692c6e35f24a8c69164284f8a890c97cff;p=mit-scheme.git

Merge branch 'master' into Gtk.
---

6ea686692c6e35f24a8c69164284f8a890c97cff
diff --cc src/microcode/uxio.c
index 8011c9ece,6ee00f59b..6badbeb17
--- a/src/microcode/uxio.c
+++ b/src/microcode/uxio.c
@@@ -889,25 -874,16 +889,29 @@@ safe_pause (void
  	n = SELECT_INTERRUPT;
      }
    UX_sigprocmask (SIG_SETMASK, &old, NULL);
-   return (n);
- #else
-   /* Wait-for-io must spin. */
-   return
-     ((OS_process_any_status_change ())
-      ? SELECT_PROCESS_STATUS_CHANGE
-      : SELECT_INTERRUPT);
+ #else /* not HAVE_SIGSUSPEND */
+   INTERRUPTABLE_EXTENT
+     (n, (((OS_process_any_status_change ())
+ 	  || (pending_interrupts_p ()))
+ 	 ? ((errno = EINTR), (-1))
+ 	 : ((UX_pause ()), (0))));
+   if (OS_process_any_status_change())
+     n = SELECT_PROCESS_STATUS_CHANGE;
+   else
+     n = SELECT_INTERRUPT;
  #endif
+   return (n);
  }
 +
 +int
 +OS_pause (int blockp)
 +{
 +  if (!blockp)
 +    {
 +      return ((OS_process_any_status_change ())
 +	      ? SELECT_PROCESS_STATUS_CHANGE
 +	      : SELECT_INTERRUPT);
 +    }
 +  else
 +    return (safe_pause ());
 +}
diff --cc src/runtime/process.scm
index d8a0a8274,655a9a4d2..d7e2b30f7
--- a/src/runtime/process.scm
+++ b/src/runtime/process.scm
@@@ -183,36 -180,37 +180,49 @@@ USA
      process))
  
  (define (subprocess-delete process)
-   (without-interrupts
-    (lambda ()
-      (if (subprocess-index process)
- 	 (begin
- 	   (remove-from-gc-finalizer! subprocess-finalizer process)
- 	   (%close-subprocess-i/o process))))))
+   (if (subprocess-index process)
+       (begin
+ 	(poll-subprocess-status process)
+ 	(close-subprocess-i/o process)
+ 	(deregister-subprocess process)
+ 	(remove-from-gc-finalizer! subprocess-finalizer process))))
  
- (define (subprocess-status process)
-   (convert-subprocess-status (%subprocess-status process)))
- 
  (define (subprocess-wait process)
-   (let loop ()
-     (hook/subprocess-wait process)
-     (let ((status (%subprocess-status process)))
-       (if (eqv? status 0)
- 	  (loop)
- 	  (convert-subprocess-status status)))))
+   (let ((result #f)
+ 	(registration))
+     (dynamic-wind
+      (lambda ()
+        (set! registration
+ 	     (register-subprocess-event
+ 	      process 'RUNNING (current-thread)
+ 	      (named-lambda (subprocess-wait-event status)
+ 		(set! result status)))))
+      (lambda ()
+        (let loop ()
+ 	 (with-thread-events-blocked
+ 	  (lambda ()
+ 	    (if (eq? result '#f)
+ 		(suspend-current-thread))
+ 	    (if (eq? result 'RUNNING)
+ 		(set! result #f))))
+ 	 (if (not result)
+ 	     (loop)
+ 	     result)))
+      (lambda ()
+        (deregister-subprocess-event registration)))))
  
 +(define (normal/subprocess-wait process)
 +  ((ucode-primitive process-wait 1) (subprocess-index process)))
 +
 +(define (nonblocking/subprocess-wait process)
 +  (without-interrupts
 +   (lambda ()
 +     (let ((status (%subprocess-status process)))
 +       (if (eqv? status 0)
 +	   (block-on-process-status-change))))))
 +
 +(define hook/subprocess-wait normal/subprocess-wait)
 +
  (define (subprocess-continue-foreground process)
    (let loop ()
      ((ucode-primitive process-continue-foreground 1)
diff --cc src/runtime/thread.scm
index 5b1a6c939,7dea7c180..f3eee99dd
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@@ -455,15 -509,8 +528,9 @@@ USA
    prev
    next)
  
- (define (initialize-io-blocking)
-   (set! io-registry (and have-select? (make-select-registry)))
-   (set! io-registrations #f)
-   unspecific)
- 
  (define (wait-for-io)
    (%maybe-toggle-thread-timer #f)
 +  (%trace ";wait-for-io: next timeout = "next-scheduled-timeout"\n")
    (let ((catch-errors
  	 (lambda (thunk)
  	   (let ((thread (console-thread)))
diff --cc tests/check.scm
index 560ea469e,5a988550b..4fb3cfaad
--- a/tests/check.scm
+++ b/tests/check.scm
@@@ -53,9 -55,10 +55,10 @@@ USA
      "runtime/test-process"
      "runtime/test-readwrite"
      "runtime/test-regsexp"
+     "runtime/test-string"
      "runtime/test-url"
      ("runtime/test-wttree" (runtime wt-tree))
 -    ;;"ffi/test-ffi"
 +    "ffi/test-ffi.scm"
      ))
  
  (with-working-directory-pathname