Don't signal error if new working directory doesn't exist. This can

sometimes be OK.

diff --git a/v7/src/runtime/wrkdir.scm b/v7/src/runtime/wrkdir.scm
index 44033552eb0f311802fdf51605905ca8c0930fe9..4fb64de5dfaf0e3422deb70c20479fc60b727170 100644 (file)
--- 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))
-\f
+
 (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