Changeset 7330 for trunk/ccl/level-1/l1-processes.lisp

Timestamp:

Oct 1, 2007, 6:13:02 PM (14 years ago)

Author:

wws

Message:

(join-process (p process) &key default)

Waits for process p to quit. Returns the values returned by it initial
function if it quits normally. If killed, returns default if
specified, or signals an error otherwise.
Patterned after SBCL's join-thread function.

File:

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

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

@@ -137 +137 @@
                          :type (satisfies valid-allocation-quantum-p))
      (dribble-stream :initform nil)
-     (dribble-saved-terminal-io :initform nil))
+     (dribble-saved-terminal-io :initform nil)
+     (result :initform (cons nil nil)
+             :reader process-result))
   (:primary-p t))
 
@@ -333 +335 @@
          (kill (handler-case
                    (restart-case
-                    (progn
-                      (apply (car initial-form) (cdr (the list initial-form)))
+                    (let ((values
+                           (multiple-value-list
+                            (apply (car initial-form)
+                                   (cdr (the list initial-form)))))
+                          (result (process-result process)))
+                      (setf (cdr result) values
+                            (car result) t)
                       (setq exited t)
                       nil)
@@ -662 +669 @@
                               (make-broadcast-stream out f)))))
       path)))
+
+(defmethod join-process ((p process) &key (default nil defaultp))
+  (wait-on-semaphore (process-termination-semaphore p) nil "join-process")
+  (let ((result (process-result p)))
+    (cond ((car result) (values-list (cdr result)))
+          (defaultp default)
+          (t (error "Failed to join ~s" p)))))