From: Nikodemus Siivola Date: Tue, 20 Jun 2006 05:38:42 +0000 (+0000) Subject: 0.9.13.50: Windows baby-steps X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=2561033fd3ed9e224dffc445262e097e5abfa920;p=sbcl.git 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. --- diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 9976de7..7e49e54 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -172,6 +172,10 @@ ("src/code/target-error" :not-host) ("src/compiler/early-backend") + ;; "src/code/toplevel.lisp" si the first to need this. It's generated + ;; automatically by grovel_headers.c, i.e. it's not in CVS. + ("output/stuff-groveled-from-headers" :not-host) + ;; a comment from classic CMU CL: ;; "These guys can supposedly come in any order, but not really. ;; Some are put at the end so that macros don't run interpreted @@ -211,10 +215,6 @@ ("src/code/string" :not-host) ("src/code/mipsstrops" :not-host) - ;; "src/code/unix.lisp" needs this. It's generated automatically by - ;; grovel_headers.c, i.e. it's not in CVS. - ("output/stuff-groveled-from-headers" :not-host) - ("src/code/unix" :not-host) #!+win32 ("src/code/win32" :not-host) #!+mach ("src/code/mach" :not-host) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 7ff9268..ac421d6 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -859,6 +859,7 @@ retained, possibly temporariliy, because it might be used internally." "MAKE-TRIVIAL-DEFAULT-PATHNAME" "PHYSICALIZE-PATHNAME" "SANE-DEFAULT-PATHNAME-DEFAULTS" + "SBCL-HOMEDIR-PATHNAME" ;; PCOUNTERs "FASTBIG-INCF-PCOUNTER-OR-FIXNUM" diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 273e758..55048db 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -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 diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index d218fd5..ade40b9 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -474,37 +474,29 @@ steppers to maintain contextual information.") &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 diff --git a/src/code/win32.lisp b/src/code/win32.lisp index 65e3d6a..98bc440 100644 --- a/src/code/win32.lisp +++ b/src/code/win32.lisp @@ -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)) diff --git a/src/runtime/globals.h b/src/runtime/globals.h index 4ffd653..60480a7 100644 --- a/src/runtime/globals.h +++ b/src/runtime/globals.h @@ -24,6 +24,13 @@ extern int foreign_function_call_active; extern boolean stop_the_world; +#ifdef LISP_FEATURE_WIN32 +#define ENVIRON _environ +#else +#define ENVIRON environ +#endif +extern char **ENVIRON; + #if defined(LISP_FEATURE_SB_THREAD) extern pthread_key_t specials; #endif diff --git a/src/runtime/runtime.c b/src/runtime/runtime.c index 1dba2da..b547453 100644 --- a/src/runtime/runtime.c +++ b/src/runtime/runtime.c @@ -271,6 +271,20 @@ main(int argc, char *argv[], char *envp[]) /* As in "--help" case, I think this is expected. */ print_version(); exit(0); + } else if (0 == strcmp(arg, "--debug-environment")) { + int n = 0; + printf("; Commandline arguments:\n"); + while (n < argc) { + printf("; %2d: \"%s\"\n", n, argv[n]); + ++n; + } + n = 0; + printf(";\n; Environment:\n"); + while (ENVIRON[n]) { + printf("; %2d: \"%s\"\n", n, ENVIRON[n]); + ++n; + } + ++argi; } else if (0 == strcmp(arg, "--end-runtime-options")) { end_runtime_options = 1; ++argi; diff --git a/src/runtime/time.c b/src/runtime/time.c index 402a19f..4b4cf9c 100644 --- a/src/runtime/time.c +++ b/src/runtime/time.c @@ -23,8 +23,17 @@ void get_timezone(time_t when, int *secwest, boolean *dst) struct tm ltm, gtm; int sw; +#ifdef LISP_FEATURE_WIN32 + /* No _r versions on Windows, but the API documentation also + * doesn't warn them about being non-reentrant... So here's + * hoping they actually are -- once Windows grows threads + * this better be checked, though. */ + ltm = *localtime(&when); + gtm = *gmtime(&when); +#else ltm = *localtime_r(&when, <m); gtm = *gmtime_r(&when, >m); +#endif sw = (((gtm.tm_hour*60)+gtm.tm_min)*60+gtm.tm_sec) - (((ltm.tm_hour*60)+ltm.tm_min)*60+ltm.tm_sec); if ((gtm.tm_wday + 1) % 7 == ltm.tm_wday) diff --git a/version.lisp-expr b/version.lisp-expr index 55305e2..a7d8a93 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.13.49" +"0.9.13.50"