Fixed cwd: Removed dynamic-wind and seperated things.

scsh/scsh.scm

@@ -118,8 +118,16 @@
  (define-record env
       c-struct	; An alien -- pointer to an envvec struct
       alist)	; Corresponding alist
-;;; TODO Give it a finaliser that uses free() to release the envvec struct.
-;;; TODO Maintain 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 (env-finalizer env)
+  (display "freeing env")
+  (%free-env (env:c-struct env)))
 
 (define env-lock (make-lock))
 (define (obtain-env-lock) (obtain-lock env-lock))	; Thunks for
@@ -134,7 +142,7 @@
   (%align-env (env:c-struct (current-env))))
 	 
 (define (make-threads-env alist)
-    (make-env (alist->envvec alist) alist))
+    (make-environ (alist->envvec alist) alist))
 
 (define (current-env) (fluid $current-env))
 
@@ -169,24 +177,33 @@
 (define (alist->env alist)
   (with-env-aligned*
    (lambda ()
-     (envvec-alist->env alist))))
+     (let ((env (current-env)))
+       (envvec-alist->env alist)
+       (set-env:alist env alist)))))
 
 (define (delete-env name)
-  (with-env-aligned*
-   (lambda ()
-     (envvec-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 name
-	 (envvec-setenv name value)
-	 (envvec-delete-env name)))))
+     (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 ()
-     (envvec-getenv name))))
+     (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
@@ -269,6 +286,8 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; working directory per thread
+
+;;; this reflects the cwd of the process
 (define-record cache
   cwd)
 
@@ -276,18 +295,52 @@
   (lambda (cache)
     (set-cache:cwd cache "")))  ; set the cache to an impossible filename.  
 
-(define unix-cwd 
+(define *unix-cwd* 
   (make-cache "")) ; Initialise the cache to an impossible filename.
 
-(define cwd-lock (make-lock))
-(define (obtain-cwd-lock) (obtain-lock cwd-lock))	; Thunks for
-(define (release-cwd-lock) (release-lock cwd-lock))	; DYNAMIC-WINDs.
+(define (unix-cwd)
+  (cache:cwd *unix-cwd*))
 
-;;; The thread-specific CWD.
+(define cwd-lock (make-lock))
+
+;;; Actually do the syscall and update the cache
+;;; assumes the cwd lock obtained
+(define (chdir-and-cache dir)
+  (process-chdir dir)
+  (set-cache:cwd *unix-cwd* (process-cwd)))
+
+;;; Dynamic-wind is not the rigth 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
+
+;;; Should be moved 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))))
+
+;;; The thread-specific CWD: A fluid
 (define $cwd (make-fluid (process-cwd)))
+
 (define (cwd) (fluid $cwd))
-(define (with-cwd* dir thunk) (let-fluid $cwd dir thunk))
 (define (set-cwd! dir) (set-fluid! $cwd dir))   
+(define (let-cwd dir thunk)
+  (let-fluid $cwd dir thunk))
+
+(define (with-cwd* dir thunk) 
+  (let ((changed-dir #f))
+    (with-lock cwd-lock
+	       (lambda ()
+		 (align-cwd!)
+		 (chdir-and-cache dir)
+		 (set! changed-dir (unix-cwd))))
+    (let-cwd changed-dir thunk)))
 
 ;; Align the Unix CWD with the scsh CWD.
 ;; Since another thread could disalign, this call and
@@ -296,16 +349,16 @@
 
 (define (align-cwd!)
   (let ((dir (cwd)))
-    (if (not (string=? (cwd) (cache:cwd unix-cwd)))
-	(begin (process-chdir dir)
-	       (set-cache:cwd unix-cwd dir)))))
+    (if (not (string=? dir (unix-cwd)))
+	  (chdir-and-cache dir))))
+
 
 (define (chdir dir)
-  (dynamic-wind obtain-cwd-lock
-		(lambda () 
-		  (process-chdir dir)
-		  (set-cwd! (process-cwd)))
-		release-cwd-lock))
+  (with-lock cwd-lock
+	     (lambda ()
+	       (align-cwd!)
+	       (chdir-and-cache dir)
+	       (set-cwd! (unix-cwd)))))
 
 ;;; For thunks that don't raise exceptions or throw to continuations,
 ;;; this is overkill & probably a little heavyweight for frequent use.
@@ -319,9 +372,11 @@
 ;;; the syscall, turn them back on. 
 
 (define (with-cwd-aligned* thunk)
-  (dynamic-wind obtain-cwd-lock
-                (lambda () (dynamic-wind align-cwd! thunk values))
-		release-cwd-lock))
+  (dynamic-wind (lambda ()
+		  (with-lock cwd-lock
+			     align-cwd!)) 
+		thunk 
+		values))
 
 ;;; example syscall
 ;;; (define (exported-delete-file fname)