From f1754363e20e3bc621574fabb958dbda2f7e61be Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 1 Feb 1999 03:29:24 +0000 Subject: [PATCH] Procedure PROCESS-ENVIRONMENT-BIND moved from Edwin to here. --- v7/src/runtime/process.scm | 35 +++++++++++++++++++++++++++++++++-- 1 file changed, 33 insertions(+), 2 deletions(-) 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 -- 2.25.1