X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=d1de6bea1eaf73fbe3aa7fdb74a39d12b6f54c0a;hb=68ea71d0f020f2726e3c56c1ec491d0af734b3a4;hp=11619295e45fd3c442557dfa96a6a41d2eaeba2c;hpb=8c685e1fee08b4d1d9ef43b8d2784ac283c94096;p=sbcl.git

diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index 1161929..d1de6be 100644
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -555,11 +555,38 @@
         (simple-file-perror "couldn't delete ~A" namestring err))))
   t)
 
+(defun ensure-trailing-slash (string)
+  (let ((last-char (char string (1- (length string)))))
+         (if (or (eql last-char #\/)
+                 #!+win32
+                 (eql last-char #\\))
+             string
+             (concatenate 'string string "/"))))
+
+(defun sbcl-homedir-pathname ()
+  (let ((sbcl-home (posix-getenv "SBCL_HOME")))
+    ;; SBCL_HOME isn't set for :EXECUTABLE T embedded cores
+    (when sbcl-home
+      (parse-native-namestring
+       (ensure-trailing-slash sbcl-home)))))
+
 ;;; (This is an ANSI Common Lisp function.)
 (defun user-homedir-pathname (&optional host)
-  "Return the home directory of the user as a pathname."
+  "Return the home directory of the user as a pathname. If the HOME
+environment variable has been specified, the directory it designates
+is returned; otherwise obtains the home directory from the operating
+system."
   (declare (ignore host))
-  (pathname (sb!unix:uid-homedir (sb!unix:unix-getuid))))
+  (parse-native-namestring
+   (ensure-trailing-slash
+    (if (posix-getenv "HOME")
+        (posix-getenv "HOME")
+        #!-win32
+        (sb!unix:uid-homedir (sb!unix:unix-getuid))
+        #!+win32
+        ;; Needs to bypass PARSE-NATIVE-NAMESTRING & ENSURE-TRAILING-SLASH
+        (return-from user-homedir-pathname
+          (sb!win32::get-folder-pathname sb!win32::csidl_profile))))))
 
 (defun file-write-date (file)
   #!+sb-doc
@@ -839,6 +866,6 @@
                            :report "Continue as if directory creation was successful."
                            nil)))
                      (setf created-p t)))))
-      (values pathname created-p))))
+      (values pathspec created-p))))
 
 (/show0 "filesys.lisp 1000")