From 4aa561b56924c46ac3ea1fbec1f8027eede38c11 Mon Sep 17 00:00:00 2001 From: mainzelm Date: Mon, 6 Aug 2001 08:33:24 +0000 Subject: [PATCH] Implement environment per thread via process-resource/thread-fluids. --- Makefile.in | 2 +- scsh/scsh.scm | 401 ++++++++++++++++++++++++---------------------- scsh/syscalls.c | 138 +--------------- scsh/syscalls.scm | 58 +------ scsh/syscalls1.c | 219 ++++++++----------------- scsh/syscalls1.h | 8 +- 6 files changed, 287 insertions(+), 539 deletions(-) diff --git a/Makefile.in b/Makefile.in index 4311461..ace139e 100644 --- a/Makefile.in +++ b/Makefile.in @@ -136,7 +136,7 @@ SCSHOBJS = \ scsh/regexp/libregex.a SCSH_INITIALIZERS = s48_init_syslog s48_init_userinfo s48_init_sighandlers \ - s48_init_re_low + s48_init_re_low s48_init_syscalls2 UNIX_OBJS = c/unix/misc.o c/unix/io.o c/unix/fd-io.o c/unix/event.o diff --git a/scsh/scsh.scm b/scsh/scsh.scm index 3bd9613..601a120 100644 --- a/scsh/scsh.scm +++ b/scsh/scsh.scm @@ -51,7 +51,6 @@ (really-fork/pipe+ fork conns maybe-thunk)) ;;; Common code. -;; JMG: this should spawn a thread to prevent deadlocking the vm (define (really-fork/pipe+ forker conns maybe-thunk) (let* ((pipes (map (lambda (conn) (call-with-values pipe cons)) conns)) @@ -113,97 +112,224 @@ -;;; Environment stuff + +;;; Should be moved to somewhere else +(define (with-lock lock thunk) + (with-handler (lambda (condition more) + (release-lock lock) + (more)) + (lambda () + (obtain-lock lock) + (let ((result (thunk))) + (release-lock lock) + result)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;; A resource is a part of the process state for which every thread +;;; has its own value +;;; uses the procedures: +;;; (process-read-resource (-> 'X)) +;;; (process-set-resource ('X -> unspec)) +;;; (resource-eq? ('X 'X -> bool)) + +;;; defines the procedures: +;;; (initialize-resource (-> unspec)) ; call on startup +;;; (with-resource* ((-> 'X) -> 'X)) +;;; (with-resource-aligned* ((-> 'X) -> 'X)) +;;; (thread-read-resource (-> 'X)) +;;; (thread-set-resource ('X -> unspec)) + +(define-syntax make-process-resource + (syntax-rules () + ((make-process-resource + initialize-resource + thread-read-resource thread-set-resource! thread-change-resource + with-resource* with-resource-aligned* + process-read-resource process-set-resource resource-eq?) +(begin +(define *resource-cache* 'uninitialized) +(define resource-lock 'uninitialized) + +(define (initialize-resource) + (set! *resource-cache* (process-read-resource)) + (set! $resource ;;; TODO The old thread-fluid will remain + (make-thread-fluid + (process-read-resource))) + (set! resource-lock (make-lock))) + +(define (cache-value) + *resource-cache*) + +;;; Actually do the syscall and update the cache +;;; assumes the resource lock obtained +(define (change-and-cache dir) + (process-set-resource dir) + (set! *resource-cache* (process-read-resource))) + +;;; Dynamic-wind is not the right thing to take care of the lock; +;;; it would release the lock on every context switch. +;;; With-lock releases the lock on a condition, using call/cc will +;;; skrew things up + +;;; The thread-specific resource: A thread fluid + +(define $resource 'emtpy-resource-value) + +(define (thread-read-resource) (thread-fluid $resource)) +(define (thread-set-resource! dir) (set-thread-fluid! $resource dir)) +(define (let-resource dir thunk) + (let-thread-fluid $resource dir thunk)) + +(define (with-resource* dir thunk) + (let ((changed-dir #f)) ; TODO 0.5 used to have a dynamic-wind here!!! + (with-lock resource-lock + (lambda () + (change-and-cache dir) + (set! changed-dir (cache-value)))) + (let-resource changed-dir thunk))) + +;; Align the value of the Unix resource with scsh's value. +;; Since another thread could disalign, this call and +;; any ensuring syscall that relies upon it should +;; be "glued together" with the resource lock. + +(define (align-resource!) + (let ((dir (thread-read-resource))) + (if (not (resource-eq? dir (cache-value))) + (change-and-cache dir)))) + +(define (thread-change-resource dir) + (with-lock resource-lock + (lambda () + (change-and-cache dir) + (thread-set-resource! (cache-value))))) + +;;; For thunks that don't raise exceptions or throw to continuations, +;;; this is overkill & probably a little heavyweight for frequent use. +;;; But it is general. +;;; +;;; A less-general, more lightweight hack could be done just for +;;; syscalls. We could probably dump the DYNAMIC-WINDs and build the +;;; rest of the pattern into one of the syscall-defining macros, or +;;; something. +;;; Olin adds the following: the efficient way to do things is not +;;; with a dynamic wind or a lock. Just turn off interrupts, sync the +;;; resource, do the syscall, turn them back on. + +(define (with-resource-aligned* thunk) + (dynamic-wind (lambda () + (with-lock resource-lock + align-resource!)) + thunk + values)) + +;;; example syscall +;;; (define (exported-delete-file fname) +;;;; (with-cwd-aligned (really-delete-file fname))) + + +(define resource-reinitializer + (make-reinitializer (lambda () (warn "calling resumer") (initialize-resource)))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; working directory per thread +(make-process-resource + initialize-cwd cwd thread-set-cwd! chdir with-cwd* with-cwd-aligned* + process-cwd process-chdir string=?) + +(initialize-cwd) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; umask per thread + +(make-process-resource + initialize-umask umask thread-set-umask set-umask + with-umask* with-umask-aligned* + process-umask set-process-umask =) + +(initialize-umask) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (define-record env - c-struct ; An alien -- pointer to an envvec struct +;;; Environment per thread + +(define-record env + envvec alist) ; Corresponding alist -;;; Once more, Olin's define-record is not sufficient -(define (make-environ c-struct alist) - (let ((env (make-env c-struct alist))) - (add-finalizer! env env-finalizer) - env)) +(define-record-discloser type/env + (lambda (e) + (list 'env (env:envvec e) (env:alist e)))) -(define (env-finalizer env) - (display "freeing env") - (%free-env (env:c-struct env))) +(define (env=? e1 e2) + (and (env:envvec e1) + (eq? (env:envvec e1) + (env:envvec e2)))) -(define env-lock (make-lock)) +(define-record envvec + environ ;; char** + ) -(define current-process-env #f) -(define $current-env #f) -(define (install-env) - (set! current-process-env - (make-threads-env (environ-env->alist))) - (set! $current-env (make-fluid current-process-env)) - (%align-env (env:c-struct (current-env)))) - -(define (make-threads-env alist) - (make-environ (alist->envvec alist) alist)) +(define (add-envvec-finalizer! envvec) + (add-finalizer! envvec envvec-finalizer)) -(define (current-env) (fluid $current-env)) +(define-exported-binding "envvec-record-type" type/envvec) +(define-exported-binding "add-envvec-finalizer!" add-envvec-finalizer!) -(define (align-env!) - (let ((current-env-val (current-env))) - (if (not (eq? current-env-val current-process-env)) - (begin (%align-env (env:c-struct current-env-val)) - (set! current-process-env current-env-val))))) +(define (envvec-finalizer envvec) + (%free-env envvec)) -(define (with-env-aligned* thunk) - (dynamic-wind (lambda () - (with-lock env-lock - align-env!)) - thunk values)) +(define (environ**-read) + (let ((alist.envvec (environ-env->alist))) + (make-env (cdr alist.envvec) (car alist.envvec)))) -(define (with-total-env* alist thunk) - (let-fluid $current-env (make-threads-env alist) thunk)) +(define (environ**-set env) + (if (env:envvec env) + (%align-env (env:envvec env)) + (set-env:envvec env (envvec-alist->env (env:alist env))))) + +(define (getenv var) + (let* ((env (thread-read-env)) + (res (assoc var (env:alist env)))) + (if res (cdr res) res))) + +(define (env->alist) + (env:alist (thread-read-env))) + +(define (setenv var val) + (let* ((env (thread-read-env)) + (alist (alist-update + var + val + (fold cons '() (env:alist env))))) + (thread-set-env! + (make-env + #f + alist + )))) + +(define (alist->env alist) + (thread-set-env! + (make-env + #f + alist))) (define (with-env* alist-delta thunk) (let ((new-env (fold (lambda (key/val alist) (alist-update (car key/val) (cdr key/val) alist)) (env->alist) alist-delta))) - (let-fluid $current-env (make-threads-env new-env) thunk))) + (with-total-env* new-env thunk))) -;(define (lp) (display (getenv "BLA")) (sleep 2000) (lp)) +(define (with-total-env* alist thunk) + (with-env-internal* (make-env #f alist) thunk)) -(define (env->alist) - (with-env-aligned* - (lambda () - (environ-env->alist)))) - -(define (alist->env alist) - (with-env-aligned* - (lambda () - (let ((env (current-env))) - (envvec-alist->env alist) - (set-env:alist env alist))))) - -(define (delete-env name) - (let ((env (current-env))) - (set-env:alist env (alist-delete name (env:alist env)))) - (envvec-delete-env name)) - -(define (setenv name value) - (with-env-aligned* - (lambda () - (if value - (begin - (envvec-setenv name value) - (let ((env (current-env))) - (set-env:alist env (alist-update name value (env:alist env))))) - (delete-env name))))) - -(define (getenv name) - (with-env-aligned* - (lambda () - (let* ((here (assoc name (env:alist (current-env)))) - (here (if here (cdr here) here))) - (if (not (equal? here (envvec-getenv name))) - (error "not equal" here (envvec-getenv name)) - here))))) - +(make-process-resource install-env thread-read-env thread-set-env! + useless-set-env + with-env-internal* with-env-aligned* + environ**-read environ**-set env=?) ;;; These two functions are obsoleted by the more general INFIX-SPLITTER and ;;; JOIN-STRINGS functions. However, we keep SPLIT-COLON-LIST defined @@ -283,126 +409,6 @@ #f)) ; AFTER doesn't appear in LIST. (cons elt list))) -;;; Should be moved to somewhere else -(define (with-lock lock thunk) - (with-handler (lambda (condition more) - (release-lock lock) - (more)) - (lambda () - (obtain-lock lock) - (let ((result (thunk))) - (release-lock lock) - result)))) - - -;;; A resource is a part of the process state for which every thread -;;; has its own value -(define-syntax make-process-resource - (syntax-rules () - ((make-process-resource - initialize-resource - thread-read-resource thread-set-resource with-resource* - with-resource-aligned* process-read-resource process-set-resource) -(begin -(define *resource-cache* 'uninitialized) -(define resource-lock 'uninitialized) - -(define (initialize-resource) - (set! *resource-cache* (process-read-resource)) - (set! resource-lock (make-lock))) - -(define (cache-value) - *resource-cache*) - -;;; Actually do the syscall and update the cache -;;; assumes the resource lock obtained -(define (change-and-cache dir) - (process-set-resource dir) - (set! *resource-cache* (process-read-resource))) - -;;; Dynamic-wind is not the right thing to take care of the lock; -;;; it would release the lock on every context switch. -;;; With-lock releases the lock on a condition, using call/cc will -;;; skrew things up - -;;; The thread-specific resource: A thread fluid - -(define $resource - (make-thread-fluid - (process-read-resource))) - -(define (thread-read-resource) (thread-fluid $resource)) -(define (set-resource! dir) (set-thread-fluid! $resource dir)) -(define (let-resource dir thunk) - (let-thread-fluid $resource dir thunk)) - -(define (with-resource* dir thunk) - (let ((changed-dir #f)) ; TODO 0.5 used to have a dynamic-wind here!!! - (with-lock resource-lock - (lambda () - (change-and-cache dir) - (set! changed-dir (cache-value)))) - (let-resource changed-dir thunk))) - -;; Align the value of the Unix resource with scsh's value. -;; Since another thread could disalign, this call and -;; any ensuring syscall that relies upon it should -;; be "glued together" with the resource lock. - -(define (align-resource!) - (let ((dir (thread-read-resource))) - (if (not (string=? dir (cache-value))) - (change-and-cache dir)))) - -(define (thread-set-resource dir) - (with-lock resource-lock - (lambda () - (change-and-cache dir) - (set-resource! (cache-value))))) - -;;; For thunks that don't raise exceptions or throw to continuations, -;;; this is overkill & probably a little heavyweight for frequent use. -;;; But it is general. -;;; -;;; A less-general, more lightweight hack could be done just for -;;; syscalls. We could probably dump the DYNAMIC-WINDs and build the -;;; rest of the pattern into one of the syscall-defining macros, or -;;; something. -;;; Olin adds the following: the efficient way to do things is not -;;; with a dynamic wind or a lock. Just turn off interrupts, sync the -;;; resource, do the syscall, turn them back on. - -(define (with-resource-aligned* thunk) - (dynamic-wind (lambda () - (with-lock resource-lock - align-resource!)) - thunk - values)) - -;;; example syscall -;;; (define (exported-delete-file fname) -;;;; (with-cwd-aligned (really-delete-file fname))) - - -(define resource-reinitializer - (make-reinitializer initialize-resource)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; working directory per thread -(make-process-resource - initialize-cwd cwd chdir with-cwd* with-cwd-aligned* - process-cwd process-chdir) - -(initialize-cwd) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; umask per thread - -(make-process-resource - initialize-umask umask set-umask with-umask* with-umask-aligned* - process-umask set-process-umask) - -(initialize-umask) ;;; Sugar: (define-simple-syntax (with-cwd dir . body) @@ -891,7 +897,10 @@ (define (really-fork clear-interactive? maybe-thunk) - (((structure-ref interrupts with-interrupts-inhibited) (lambda () + (with-env-aligned* ; not neccessary here but doing it on exec + ; genereates no cache in the parent + (lambda () + (((structure-ref interrupts with-interrupts-inhibited) (lambda () (let ((pid (%%fork))) (if (zero? pid) @@ -907,7 +916,7 @@ ;; Parent (let ((proc (new-child-proc pid))) - (lambda () proc)))))))) + (lambda () proc)))))))))) (define (exit . maybe-status) diff --git a/scsh/syscalls.c b/scsh/syscalls.c index c03a275..f8f17fa 100644 --- a/scsh/syscalls.c +++ b/scsh/syscalls.c @@ -651,132 +651,6 @@ s48_value df_scm_sort_filevec(s48_value g1, s48_value g2) return S48_FALSE; } -s48_value df_scm_envvec(void) -{ - extern s48_value scm_envvec(void); - s48_value ret1 = S48_FALSE; - S48_DECLARE_GC_PROTECT(1); - s48_value r1; - - - - S48_GC_PROTECT_1(ret1); - r1 = scm_envvec(); - ret1 = r1; - S48_GC_UNPROTECT(); - return ret1; -} - -s48_value df_install_env(s48_value g1) -{ - extern int install_env(s48_value ); - s48_value ret1 = S48_FALSE; - S48_DECLARE_GC_PROTECT(1); - int r1; - - - - S48_GC_PROTECT_1(ret1); - r1 = install_env(g1); - ret1 = errno_or_false(r1); - S48_GC_UNPROTECT(); - return ret1; -} - -s48_value df_create_env(s48_value g1, s48_value mv_vec) -{ - extern int create_env(s48_value , s48_value *); - s48_value ret1 = S48_FALSE; - S48_DECLARE_GC_PROTECT(2); - int r1; - s48_value r2 = 0; - - - - S48_GC_PROTECT_2(mv_vec,ret1); - r1 = create_env(g1, &r2); - ret1 = errno_or_false(r1); - S48_VECTOR_SET(mv_vec,0,r2); - S48_GC_UNPROTECT(); - return ret1; -} - -s48_value df_align_env(s48_value g1) -{ - extern void align_env(s48_value ); - - - align_env(g1); - return S48_FALSE; -} - -s48_value df_free_envvec(s48_value g1) -{ - extern s48_value free_envvec(s48_value ); - s48_value ret1 = S48_FALSE; - S48_DECLARE_GC_PROTECT(1); - s48_value r1; - - - - S48_GC_PROTECT_1(ret1); - r1 = free_envvec(g1); - ret1 = r1; - S48_GC_UNPROTECT(); - return ret1; -} - -s48_value df_envvec_setenv(s48_value g1, s48_value g2) -{ - extern s48_value envvec_setenv(s48_value , s48_value ); - s48_value ret1 = S48_FALSE; - S48_DECLARE_GC_PROTECT(1); - s48_value r1; - - - - S48_GC_PROTECT_1(ret1); - r1 = envvec_setenv(g1, g2); - ret1 = r1; - S48_GC_UNPROTECT(); - return ret1; -} - -s48_value df_getenv(s48_value g1, s48_value mv_vec) -{ - extern char *getenv(const char *); - s48_value ret1 = S48_FALSE; - S48_DECLARE_GC_PROTECT(2); - char *r1; - - - - S48_GC_PROTECT_2(mv_vec,ret1); - r1 = getenv(s48_extract_string(g1)); - ret1 = S48_VECTOR_REF(mv_vec,0); - SetAlienVal(S48_CAR(ret1),(long) r1); S48_SET_CDR(ret1,strlen_or_false(r1));//str-and-len - S48_GC_UNPROTECT(); - return ret1; -} - -#define errno_on_nonzero_or_false(x) ((x) ? s48_enter_fixnum(errno) : S48_FALSE) - -s48_value df_delete_env(s48_value g1) -{ - extern s48_value delete_env(s48_value ); - s48_value ret1 = S48_FALSE; - S48_DECLARE_GC_PROTECT(1); - s48_value r1; - - - - S48_GC_PROTECT_1(ret1); - r1 = delete_env(g1); - ret1 = r1; - S48_GC_UNPROTECT(); - return ret1; -} - s48_value df_sleep_until(s48_value g1) { extern s48_value sleep_until(time_t ); @@ -872,14 +746,10 @@ void s48_init_syscalls(void) S48_EXPORT_FUNCTION(df_pause); S48_EXPORT_FUNCTION(df_open_dir); S48_EXPORT_FUNCTION(df_scm_sort_filevec); - S48_EXPORT_FUNCTION(df_scm_envvec); - S48_EXPORT_FUNCTION(df_install_env); - S48_EXPORT_FUNCTION(df_create_env); - S48_EXPORT_FUNCTION(df_align_env); - S48_EXPORT_FUNCTION(df_free_envvec); - S48_EXPORT_FUNCTION(df_envvec_setenv); - S48_EXPORT_FUNCTION(df_getenv); - S48_EXPORT_FUNCTION(df_delete_env); + S48_EXPORT_FUNCTION(scm_envvec); + S48_EXPORT_FUNCTION(create_env); + S48_EXPORT_FUNCTION(align_env); + S48_EXPORT_FUNCTION(free_envvec); S48_EXPORT_FUNCTION(set_cloexec); S48_EXPORT_FUNCTION(fcntl_read); S48_EXPORT_FUNCTION(fcntl_write); diff --git a/scsh/syscalls.scm b/scsh/syscalls.scm index b31f377..1817074 100644 --- a/scsh/syscalls.scm +++ b/scsh/syscalls.scm @@ -808,68 +808,26 @@ ;;; ENV->ALIST -(define-foreign %load-env (scm_envvec) - desc) - -(define (env->list) - (%load-env)) +(define-stubless-foreign %load-env () "scm_envvec") (define (environ-env->alist) - (env-list->alist (env->list))) - + (let ((env-list.envvec (%load-env))) + (cons (env-list->alist (car env-list.envvec)) + (cdr env-list.envvec)))) ;;; ALIST->ENV -(define-foreign %install-env/errno - (install_env (vector-desc env-vec)) - (to-scheme integer errno_or_false)) - -(define-errno-syscall (%install-env env-vec) %install-env/errno) +;;; (%create-env ((vector 'X) -> address)) +(define-stubless-foreign %create-env (envvec) "create_env") ;;; assumes aligned env (define (envvec-alist->env alist) - (%install-env (alist->env-vec alist))) - -;;; create new env for thread -(define-foreign %create-env/errno - (create_env (vector-desc env-vec)) - (to-scheme integer errno_or_false) - desc) - -(define-errno-syscall (%create-env env-vec) - %create-env/errno - bvec) - -(define (alist->envvec alist) (%create-env (alist->env-vec alist))) -(define-foreign %align-env - (align_env (desc)) - ignore) +(define-stubless-foreign %align-env (envvec) "align_env") -(define-foreign %free-env - (free_envvec (desc)) - desc) -;;; GETENV, SETENV -;;; they all assume an aligned env - - -(define-foreign %envvec-setenv (envvec_setenv (desc name) (desc entry)) - desc) - -(define (envvec-setenv name value) - (%envvec-setenv name (string-append name "=" value))) - -(define-foreign envvec-getenv (getenv (string var)) - static-string) - -(foreign-source - "#define errno_on_nonzero_or_false(x) ((x) ? s48_enter_fixnum(errno) : S48_FALSE)" - "" "") - -(define-foreign envvec-delete-env (delete_env (desc var)) - desc) +(define-stubless-foreign %free-env (envvec) "free_envvec") ;;; Fd-ports diff --git a/scsh/syscalls1.c b/scsh/syscalls1.c index e9cf887..79642ed 100644 --- a/scsh/syscalls1.c +++ b/scsh/syscalls1.c @@ -491,24 +491,11 @@ s48_value scsh_seteuid(s48_value uid) /* Environment hackery ******************************************************************************* */ -struct envvec { - char **env; /* Null-terminated vector of strings. Malloc'd. */ - int size; /* Length of env. */ - int revealed; /* True => exported to C code */ - int gcable; /* True => no pointers to us from Scheme heap. */ -}; -/* Note that the SIZE field tells you how many words of memory are allocated -** for the block of memory to which the ENV field points. This includes the -** terminating null pointer, and may include more words beyond that. It is -** *not* the number of strings stored in ENV; it is always greater than this -** value. -** -** The REVEALED field is incremented if either the ENV block or the entire -** struct is handed out to C code. -** -** If the structure becomes gc'able, but is REVEALED (hence cannot be freed), -** the GC simply sets GCABLE and forgets about it. -*/ +static s48_value envvec_record_type_binding = S48_FALSE; +static s48_value add_envvec_finalizerB_binding = S48_FALSE; + +#define ENVVEC_ENVIRON(envvec) \ + ((char**) s48_extract_integer(S48_RECORD_REF((envvec),0))) /* The envvec corresponding to the current environment. ** Null if the current environment has no corresponding envvec struct @@ -516,186 +503,101 @@ struct envvec { ** startup time.) That is, ** !current_env || current_env->env == environ */ -struct envvec *current_env = 0; +s48_value current_env = S48_FALSE; -void align_env(s48_value pointer_to_struct) +s48_value align_env(s48_value envvec) { - struct envvec* thread_env; - thread_env = (struct envvec*) s48_extract_integer(pointer_to_struct); - environ = thread_env->env; - current_env = thread_env; + environ = ENVVEC_ENVIRON(envvec); + current_env = envvec; + return S48_TRUE; } -s48_value free_envvec (s48_value pointer_to_struct) +char** original_environ = 0; + +s48_value free_envvec (s48_value envvec) { - struct envvec* envv = (struct envvec*) s48_extract_integer(pointer_to_struct); - int i; - if (envv->revealed) + char** env = ENVVEC_ENVIRON(envvec); + int i=0; + if (env == original_environ) { - envv->gcable = 1; return S48_FALSE; } - for (i=0; isize; i++) - Free(envv->env[i]); - Free(envv->env); - Free(envv); + while (env[i] != 0){ + Free(env[i]); + i++; + } + Free(env); return S48_TRUE; } -s48_value envvec_setenv(s48_value scheme_name, s48_value entry){ - char * name = s48_extract_string(scheme_name); - int namelen = strlen(name); - char **ptr = environ; - char ** newenv; - int size; - int number_of_entries = 0; - char * newentry = Malloc(char, S48_STRING_LENGTH(entry) + 1); - if ( !newentry) return s48_enter_fixnum(errno); +s48_value make_envvec(char** newenv){ + s48_value thread_env; - if (!current_env) { - fprintf(stderr, "no current_env, giving up" ); - exit (1); - } - size = current_env->size; - while (*ptr){ - if ( ( strncmp(*ptr, name, namelen) == 0) && (*ptr)[namelen] == '=') - { - *ptr = strcpy(newentry,s48_extract_string(entry)); - return S48_FALSE; - } - ptr++; - number_of_entries++; - } - if (number_of_entries >= size) { // I never had this problem, but... - fprintf(stderr, "currupt env, giving up %d %d", number_of_entries,size); - exit (1); - } - else if (number_of_entries < (size - 1)) // is space left after the NULL ? - { - *ptr = strcpy(newentry,s48_extract_string(entry)); - *++ptr = NULL; - return S48_FALSE; - } - else // number_of_entries == (size - 1) - { - int newsize = size + 1; // TODO: add more - char ** newenv = Malloc (char *, newsize); - if( !newenv) return s48_enter_fixnum(errno); - current_env->env = newenv; - current_env->size = newsize; - memcpy(newenv, environ, number_of_entries * sizeof (char *)); - newenv[number_of_entries] = strcpy(newentry, s48_extract_string(entry)); - newenv[number_of_entries + 1] = NULL; - environ = newenv; - return S48_FALSE; - } + thread_env = s48_make_record(envvec_record_type_binding); + + S48_RECORD_SET(thread_env, 0, s48_enter_integer((long)newenv)); + s48_call_scheme(S48_SHARED_BINDING_REF(add_envvec_finalizerB_binding), + 1, + thread_env); + return thread_env; } s48_value scm_envvec(){ - return char_pp_2_string_list(environ); + s48_value thread_env; + if (current_env == 0){ + thread_env = make_envvec(environ); + current_env = thread_env; + } + else thread_env = current_env; + + if (original_environ == 0) + original_environ = environ; + + return s48_cons (char_pp_2_string_list(environ), + thread_env); } /* Load the (Scheme) strings in the (Scheme) vector VEC into environ. -** Somewhat wasteful of memory: we do not free any of the memory -** in the old environ -- don't know if it is being shared elsewhere. */ -int install_env(s48_value vec) +s48_value create_env(s48_value vec) { int i, envsize; char **newenv; - - envsize = S48_VECTOR_LENGTH(vec); - - if (envsize >= (current_env->size)) - { - newenv = Malloc(char*, envsize+1); - if( !newenv ) return errno; - Free(current_env->env); - current_env->env = newenv; - } - else newenv = current_env->env; - - for( i=0; ienv = newenv; - thread_env->size = envsize + 1; - thread_env->revealed = 0; - thread_env->gcable = 0; + if( !newenv ) s48_raise_out_of_memory_error(); + for( i=0; i