From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 1 Feb 1999 03:29:24 +0000 (+0000)
Subject: Procedure PROCESS-ENVIRONMENT-BIND moved from Edwin to here.
X-Git-Tag: 20090517-FFI~4654
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f1754363e20e3bc621574fabb958dbda2f7e61be;p=mit-scheme.git

Procedure PROCESS-ENVIRONMENT-BIND moved from Edwin to here.
---

diff --git a/v7/src/runtime/process.scm b/v7/src/runtime/process.scm
index 9529bc0ba..22c396bc4 100644
--- a/v7/src/runtime/process.scm
+++ b/v7/src/runtime/process.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: process.scm,v 1.22 1999/01/02 06:11:34 cph Exp $
+$Id: process.scm,v 1.23 1999/02/01 03:29:24 cph Exp $
 
 Copyright (c) 1989-1999 Massachusetts Institute of Technology
 
@@ -341,4 +341,35 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
       master-name
       (make-subprocess filename arguments environment
 		       slave-name 'CTTY 'CTTY 'CTTY
-		       master-channel master-channel master-channel))))
\ No newline at end of file
+		       master-channel master-channel master-channel))))
+
+;;;; Environment Bindings
+
+(define (process-environment-bind environment . bindings)
+  (let ((bindings* (vector->list environment)))
+    (for-each (lambda (binding)
+		(let ((b
+		       (find-environment-variable
+			(environment-binding-name binding)
+			bindings*)))
+		  (if b
+		      (set-car! b binding)
+		      (begin
+			(set! bindings* (cons binding bindings*))
+			unspecific))))
+	      bindings)
+    (list->vector bindings*)))
+
+(define (environment-binding-name binding)
+  (let ((index (string-find-next-char binding #\=)))
+    (if (not index)
+	binding
+	(string-head binding index))))
+
+(define (find-environment-variable name bindings)
+  (let ((prefix (string-append name "=")))
+    (let loop ((bindings bindings))
+      (and (not (null? bindings))
+	   (if (string-prefix? prefix (car bindings))
+	       bindings
+	       (loop (cdr bindings)))))))
\ No newline at end of file