Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/code filesys.lisp, 1.57, 1.58 toplevel.lisp, 1.84, 1.85 win32.lisp, 1.7, 1.8
|
From: Nikodemus S. <de...@us...> - 2006-06-20 05:38:48
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv4437/src/code Modified Files: filesys.lisp toplevel.lisp win32.lisp Log Message: 0.9.13.50: Windows baby-steps * Less sucky toplevel-init: use PARSE-NATIVE-NAMESTRING to deal with user-supplied init-file names, and refactor the logic between Posix and Windows. * New runtime option: --debug-environment, prints out the command line arguments and environment before anything fancy gets done to them. Good for debugging startup from Windows shortcuts, etc. * Less magic constants, more groveled stuff. * SB-WIN32::GET-FOLDER-PATH renamed to SB-WIN32::GET-FOLDER-PATHNAME, and it now returns pathnames instead of strings. * Add internal function SBCL-HOMEDIR-PATHNAME, and centralize the SBCL_HOME stuff there. * Still LESS_SHOUTING. * Move stuff-groveled-from-headers.lisp earlier in the build-order, so toplevel.lisp can use it. * No localtime_r and gmtime_r on Windows. Index: filesys.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/filesys.lisp,v retrieving revision 1.57 retrieving revision 1.58 diff -u -d -r1.57 -r1.58 --- filesys.lisp 6 Apr 2006 10:39:34 -0000 1.57 +++ filesys.lisp 20 Jun 2006 05:38:43 -0000 1.58 @@ -555,21 +555,35 @@ (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 () + (parse-native-namestring + (ensure-trailing-slash (posix-getenv "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 be specified, returns the directory +is designated, otherwise obtains the home directory from the +operating system." (declare (ignore host)) - #!-win32 - (pathname (sb!unix:uid-homedir (sb!unix:unix-getuid))) - #!+win32 - (pathname (if (posix-getenv "HOME") - (let* ((path (posix-getenv "HOME")) - (last-char (char path (1- (length path))))) - (if (or (char= last-char #\/) - (char= last-char #\\)) - path - (concatenate 'string path "/"))) - (sb!win32::get-folder-path 40)))) ;;SB-WIN32::CSIDL_PROFILE + (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 Index: toplevel.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/toplevel.lisp,v retrieving revision 1.84 retrieving revision 1.85 diff -u -d -r1.84 -r1.85 --- toplevel.lisp 23 Apr 2006 12:21:12 -0000 1.84 +++ toplevel.lisp 20 Jun 2006 05:38:43 -0000 1.85 @@ -474,37 +474,29 @@ &rest default-init-file-names) (declare (type list default-init-file-names)) (if explicitly-specified-init-file-name - (or (probe-file explicitly-specified-init-file-name) - (startup-error "The file ~S was not found." - explicitly-specified-init-file-name)) + (or (probe-file + (parse-native-pathname + explicitly-specified-init-file-name)) + (startup-error "The file ~S was not found." + explicitly-specified-init-file-name)) (find-if (lambda (x) - (and (stringp x) (probe-file x))) - default-init-file-names))) - ;; shared idiom for creating default names for - ;; SYSINITish and USERINITish files - (init-file-name (maybe-dir-name basename) - (and maybe-dir-name - (concatenate 'string maybe-dir-name "/" basename)))) + (and (pathnamep x) (probe-file x))) + default-init-file-names)))) (let ((sysinit-truename - #!-win32 (probe-init-files sysinit - (init-file-name (posix-getenv "SBCL_HOME") - "sbclrc") - "/etc/sbclrc") - #!+win32 (probe-init-files sysinit - (init-file-name (posix-getenv "SBCL_HOME") - "sbclrc") - (concatenate 'string - (sb!win32::get-folder-path 35) ;;SB-WIN32::CSIDL_COMMON_APPDATA - "\\sbcl\\sbclrc"))) - - (userinit-truename - #!-win32 (probe-init-files userinit - (init-file-name (posix-getenv "HOME") - ".sbclrc")) - #!+win32 (probe-init-files userinit - (init-file-name (namestring (user-homedir-pathname)) - ".sbclrc")))) - + (probe-init-files sysinit + (merge-pathnames (sbcl-homedir-pathname) + "sbclrc") + #!-win32 + "/etc/sbclrc" + #!+win32 + (merge-pathnames + (sb!win32::get-folder-pathname + sb!win32::csidl_common_appdata) + "\\sbcl\\sbclrc"))) + (userinit-truename + (probe-init-files userinit + (merge-pathnames (user-homedir-pathname) + ".sbclrc")))) ;; This CATCH is needed for the debugger command TOPLEVEL to ;; work. (catch 'toplevel-catcher Index: win32.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/win32.lisp,v retrieving revision 1.7 retrieving revision 1.8 diff -u -d -r1.7 -r1.8 --- win32.lisp 18 Jun 2006 23:47:58 -0000 1.7 +++ win32.lisp 20 Jun 2006 05:38:43 -0000 1.8 @@ -402,26 +402,27 @@ err-code (sb!win32::get-last-error-message err-code)))) -(defun get-folder-path (CSIDL) +(defun get-folder-pathname (csidl) "http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp" - (with-alien ((apath (* tchar) (make-alien tchar (1+ MAX_PATH)))) + (with-alien ((apath (* tchar) (make-alien tchar (1+ max_path)))) (alien-funcall (extern-alien #!-sb-unicode "SHGetFolderPathA@20" #!+sb-unicode "SHGetFolderPathW@20" (function int handle int handle dword (* tchar))) - 0 CSIDL 0 0 apath) - (concatenate 'string (ucs2->string&free apath) "\\"))) + 0 csidl 0 0 apath) + (parse-native-namestring + (concatenate 'string (ucs2->string&free apath) "\\")))) (defun sb!unix:posix-getcwd () - (with-alien ((apath (* tchar) (make-alien tchar (1+ MAX_PATH))) + (with-alien ((apath (* tchar) (make-alien tchar (1+ max_path))) (afunc (function dword dword (* tchar)) :extern #!-sb-unicode "GetCurrentDirectoryA@8" #!+sb-unicode "GetCurrentDirectoryW@8")) - (let ((ret (alien-funcall afunc (1+ MAX_PATH) apath))) + (let ((ret (alien-funcall afunc (1+ max_path) apath))) (when (zerop ret) (win32-error "GetCurrentDirectory")) - (when (> ret (1+ MAX_PATH)) + (when (> ret (1+ max_path)) (free-alien apath) (setf apath (make-alien tchar ret)) (alien-funcall afunc ret apath)) |