Implement environment per thread via process-resource/thread-fluids.

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
 

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
+;;; Environment per thread
-      c-struct	; An alien -- pointer to an envvec struct
+
+(define-record env
+      envvec
       alist)	; Corresponding alist
 
-;;; Once more, Olin's define-record is not sufficient
+(define-record-discloser type/env
-(define (make-environ c-struct alist)
+  (lambda (e)
-  (let ((env (make-env c-struct alist)))
+    (list 'env (env:envvec e) (env:alist e))))
-    (add-finalizer! env env-finalizer)
-    env))
 
-(define (env-finalizer env)
+(define (env=? e1 e2)
-  (display "freeing env")
+  (and (env:envvec e1)
-  (%free-env (env:c-struct env)))
+       (eq? (env:envvec e1) 
+	    (env:envvec e2))))
 
-(define env-lock (make-lock))
+(define-record envvec 
+  environ ;; char**
+  )
 
-(define current-process-env  #f)
+(define (add-envvec-finalizer! envvec)
-(define  $current-env #f)
+  (add-finalizer! envvec envvec-finalizer))
-(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 (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!)
+(define (envvec-finalizer envvec)
-  (let ((current-env-val (current-env)))
+  (%free-env envvec))
-    (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 (with-env-aligned* thunk)
+(define (environ**-read)
-  (dynamic-wind (lambda ()
+  (let ((alist.envvec (environ-env->alist)))
-		  (with-lock env-lock
+    (make-env (cdr alist.envvec) (car alist.envvec))))
-			     align-env!)) 
-		thunk values))
 
-(define (with-total-env* alist thunk)
+(define (environ**-set env)
-  (let-fluid $current-env (make-threads-env alist) thunk))
+   (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)
+(make-process-resource install-env thread-read-env thread-set-env! 
-  (with-env-aligned*
+		       useless-set-env
-   (lambda ()
+		       with-env-internal* with-env-aligned* 
-     (environ-env->alist))))
+		       environ**-read environ**-set env=?)
-
-(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)))))
-	
 
 ;;; 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)

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(scm_envvec);
-    S48_EXPORT_FUNCTION(df_install_env);
+    S48_EXPORT_FUNCTION(create_env);
-    S48_EXPORT_FUNCTION(df_create_env);
+    S48_EXPORT_FUNCTION(align_env);
-    S48_EXPORT_FUNCTION(df_align_env);
+    S48_EXPORT_FUNCTION(free_envvec);
-    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(set_cloexec);
     S48_EXPORT_FUNCTION(fcntl_read);
     S48_EXPORT_FUNCTION(fcntl_write);

scsh/syscalls.scm

@@ -808,68 +808,26 @@
 
 ;;; ENV->ALIST
 
-(define-foreign %load-env (scm_envvec)
+(define-stubless-foreign %load-env () "scm_envvec")
-  desc)
-
-(define (env->list)
-  (%load-env))
 
 (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 
+;;; (%create-env ((vector 'X) -> address))
-  (install_env (vector-desc env-vec))
+(define-stubless-foreign %create-env (envvec) "create_env")
-  (to-scheme integer errno_or_false))
-
-(define-errno-syscall (%install-env env-vec) %install-env/errno)
 
 ;;; 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
+(define-stubless-foreign %align-env (envvec) "align_env")
-  (align_env (desc))
-  ignore)
 
-(define-foreign %free-env
+(define-stubless-foreign %free-env (envvec) "free_envvec")
-  (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)
 
 
 ;;; Fd-ports

scsh/syscalls1.c

@@ -491,24 +491,11 @@ s48_value scsh_seteuid(s48_value uid)
 /* Environment hackery
 *******************************************************************************
 */
-struct envvec {
+static s48_value envvec_record_type_binding = S48_FALSE;
-    char **env; 	/* Null-terminated vector of strings. Malloc'd. */
+static s48_value add_envvec_finalizerB_binding = S48_FALSE;
-    int size;   	/* Length of env. */
+
-    int revealed;	/* True => exported to C code */
+#define ENVVEC_ENVIRON(envvec) \
-    int gcable;		/* True => no pointers to us from Scheme heap. */
+  ((char**) s48_extract_integer(S48_RECORD_REF((envvec),0)))
-};
-/* 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.
-*/
 
 /* 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;
+    environ = ENVVEC_ENVIRON(envvec);
-    thread_env =  (struct envvec*) s48_extract_integer(pointer_to_struct);
+    current_env = envvec;     
-    environ = thread_env->env; 
+    return S48_TRUE;
-    current_env = thread_env; 
 }
 
-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);
+  char** env = ENVVEC_ENVIRON(envvec);
-  int i;
+  int i=0;
-  if (envv->revealed)
+  if (env == original_environ)
     {
-      envv->gcable = 1;
       return S48_FALSE;
     }
-  for (i=0; i<envv->size; i++)
+  while (env[i] != 0){
-    Free(envv->env[i]);
+    Free(env[i]);
-  Free(envv->env);
+    i++;
-  Free(envv);
+  }
+  Free(env);
   return S48_TRUE;
 }
 
-s48_value envvec_setenv(s48_value scheme_name, s48_value entry){
+s48_value make_envvec(char** newenv){
-  char * name = s48_extract_string(scheme_name);
+  s48_value thread_env;
-  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);
 
-  if (!current_env)  {
+  thread_env = s48_make_record(envvec_record_type_binding);
-    fprintf(stderr, "no current_env, giving up" );
+  
-    exit (1);
+  S48_RECORD_SET(thread_env, 0, s48_enter_integer((long)newenv));
-  }
+  s48_call_scheme(S48_SHARED_BINDING_REF(add_envvec_finalizerB_binding),
-  size = current_env->size;	
+		  1,
-  while (*ptr){
+		  thread_env);
-    if ( ( strncmp(*ptr, name, namelen) == 0) && (*ptr)[namelen] == '=')
+  return thread_env;
-      {
-	*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;
-    }
 }
 
 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;
-
+  s48_value thread_env;
-  envsize = S48_VECTOR_LENGTH(vec);
+  S48_DECLARE_GC_PROTECT(1);
-  
+  S48_GC_PROTECT_1(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; i<envsize; i++ ) {
-    char *s = scheme2c_strcpy(S48_VECTOR_REF(vec,i));
-    if (!s) {
-      /* Return all the memory and bail out. */
-      int e = errno;
-      while(--i) Free(newenv[i]);
-      Free(newenv);
-      return e;
-    }
-    newenv[i] = s;
-  }
-
-  newenv[i] = NULL;
-  environ = newenv;
-  return 0;
-}
-
-int create_env(s48_value vec,  s48_value * envvec_addr)
-{
-  int i, envsize;
-  char **newenv;
-  struct envvec* thread_env;
  
   envsize = S48_VECTOR_LENGTH(vec);
     
   newenv = Malloc(char*, envsize+1);
-  if( !newenv ) return errno;
+  if( !newenv ) s48_raise_out_of_memory_error();
-  thread_env = Malloc (struct envvec, 4); // TODO: why 4 ??
+  
-   if( !thread_env ) {
-    Free (newenv);
-    return errno;
-  }
-
-  thread_env->env = newenv;
-  thread_env->size = envsize + 1;
-  thread_env->revealed = 0;
-  thread_env->gcable = 0;
   
   for( i=0; i<envsize; i++ ) {
     char *s = scheme2c_strcpy(S48_VECTOR_REF(vec,i));
     if (!s) {
       /* Return all the memory and bail out. */
-      int e = errno;
       while(--i) Free(newenv[i]);
       Free(newenv);
       Free(thread_env);
-      return e;
+      s48_raise_out_of_memory_error();
     }
     newenv[i] = s;
   }
 
   newenv[envsize] = NULL;
- 
+
-  *envvec_addr = s48_enter_integer((long) thread_env);
+  thread_env = make_envvec(newenv);
+  environ = newenv;
+  current_env = thread_env;
+
+  S48_GC_UNPROTECT();
+  return thread_env;
   
-  return 0;
 }
   
-/* Delete the env var. */
-s48_value delete_env(s48_value name)
-{
-  int varlen = S48_STRING_LENGTH (name);
-  char * var = s48_extract_string (name);
-  char **ptr = environ;
-  char **ptr2;
-  if (!current_env)  {
-    fprintf(stderr, "no current_env, giving up" );
-    exit (1);
-  }
-  do if( !*++ptr ) return S48_FALSE;
-  while( strncmp(*ptr, var, varlen) || (*ptr)[varlen] != '=' );
-  ptr2 = ptr;
-  while (*++ptr2);
-  *ptr = *ptr2;
-  *ptr2 = NULL;
-  return S48_TRUE; 
-}	
-
-
 /*****************************************************************************/
 
 /* N.B.: May be unaligned. */
@@ -766,3 +668,12 @@ s48_value scm_crypt(s48_value key, s48_value salt)
 
   return s48_enter_string (ret);
 }
+
+void s48_init_syscalls2(){
+  S48_GC_PROTECT_GLOBAL(envvec_record_type_binding);
+  S48_GC_PROTECT_GLOBAL(add_envvec_finalizerB_binding);
+  S48_GC_PROTECT_GLOBAL(current_env);
+  envvec_record_type_binding = s48_get_imported_binding("envvec-record-type");
+  add_envvec_finalizerB_binding = 
+    s48_get_imported_binding("add-envvec-finalizer!");
+}

scsh/syscalls1.h

@@ -65,13 +65,13 @@ s48_value scsh_setuid(s48_value uid);
 
 s48_value scsh_seteuid(s48_value uid);
 
-int put_env(const char *s);
+s48_value align_env(s48_value pointer_to_struct);
+
+s48_value free_envvec (s48_value pointer_to_struct);
 
 s48_value scm_envvec(void);
 
-int install_env(s48_value vec);
+s48_value create_env(s48_value vec);
-
-s48_value delete_env(s48_value var);
 
 s48_value scm_gethostname(void);