From 083a4a335cc4f174b8706cfc482a29da5c37ec08 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 6 Jun 2007 02:53:48 +0000
Subject: [PATCH] Don't signal error if new working directory doesn't exist. 
 This can sometimes be OK.

---
 v7/src/runtime/wrkdir.scm | 39 ++++++++++++++++-----------------------
 1 file changed, 16 insertions(+), 23 deletions(-)

diff --git a/v7/src/runtime/wrkdir.scm b/v7/src/runtime/wrkdir.scm
index 44033552e..4fb64de5d 100644
--- a/v7/src/runtime/wrkdir.scm
+++ b/v7/src/runtime/wrkdir.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: wrkdir.scm,v 14.12 2007/01/05 21:19:28 cph Exp $
+$Id: wrkdir.scm,v 14.13 2007/06/06 02:53:48 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -29,7 +29,7 @@ USA.
 ;;; package: (runtime working-directory)
 
 (declare (usual-integrations))
-
+
 (define (initialize-package!)
   (reset!)
   (add-event-receiver! event:after-restore reset!))
@@ -49,26 +49,19 @@ USA.
   *working-directory-pathname*)
 
 (define (set-working-directory-pathname! name)
-  (let ((pathname
-	 (pathname-as-directory
-	  (merge-pathnames name *working-directory-pathname*))))
-    (if (not (file-directory? pathname))
-	(error "Not a valid directory:" pathname))
-    (let ((pathname (pathname-simplify pathname)))
-      (set! *working-directory-pathname* pathname)
-      (set! *default-pathname-defaults*
-	    (merge-pathnames pathname *default-pathname-defaults*))
-      (cmdl/set-default-directory (nearest-cmdl) pathname)
-      pathname)))
+  (let ((pathname (new-pathname name)))
+    (set! *working-directory-pathname* pathname)
+    (set! *default-pathname-defaults* pathname)
+    (cmdl/set-default-directory (nearest-cmdl) pathname)
+    pathname))
 
 (define (with-working-directory-pathname name thunk)
-  (let ((pathname
-	 (pathname-as-directory
-	  (merge-pathnames name *working-directory-pathname*))))
-    (if (not (file-directory? pathname))
-	(error "Not a valid directory:" pathname))
-    (let ((pathname (pathname-simplify pathname)))
-      (fluid-let ((*working-directory-pathname* pathname)
-		  (*default-pathname-defaults*
-		   (merge-pathnames pathname *default-pathname-defaults*)))
-	(thunk)))))
\ No newline at end of file
+  (let ((pathname (new-pathname name)))
+    (fluid-let ((*working-directory-pathname* pathname)
+		(*default-pathname-defaults* pathname))
+      (thunk))))
+
+(define (new-pathname name)
+  (pathname-simplify
+   (pathname-as-directory
+    (merge-pathnames name *working-directory-pathname*))))
\ No newline at end of file
-- 
2.25.1