From: Juho S. <js...@us...> - 2006-09-20 12:08:26
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv14676/src/code Modified Files: toplevel.lisp win32-os.lisp win32.lisp Log Message: 0.9.16.41: More win32 fixes. (Thanks to Yaroslav Kavenchuk: sbcl-devel "win32 regression" on 2006-09-18 and "merge-pathnames on win32" on 2006-09-19) * Double the size of the string buffers given to syscalls on sb-unicode, since the data is going to be in UCS-2 instead of some single-octet encoding * Fix the code for finding the system-wide sbclrc * Whitespace Index: toplevel.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/toplevel.lisp,v retrieving revision 1.90 retrieving revision 1.91 diff -u -d -r1.90 -r1.91 --- toplevel.lisp 18 Sep 2006 20:09:13 -0000 1.90 +++ toplevel.lisp 20 Sep 2006 12:08:22 -0000 1.91 @@ -43,9 +43,9 @@ (when sbcl-homedir (probe-file (merge-pathnames sbcl-homedir "sbclrc")))) #!+win32 - (merge-pathnames (sb!win32::get-folder-pathname - sb!win32::csidl_common_appdata) - "\\sbcl\\sbclrc") + (merge-pathnames "sbcl\\sbclrc" + (sb!win32::get-folder-pathname + sb!win32::csidl_common_appdata)) #!-win32 "/etc/sbclrc")) Index: win32-os.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/win32-os.lisp,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- win32-os.lisp 17 Sep 2006 09:50:00 -0000 1.4 +++ win32-os.lisp 20 Sep 2006 12:08:22 -0000 1.5 @@ -26,11 +26,11 @@ if not available." (or *software-version* (setf *software-version* - (multiple-value-bind (MajorVersion MinorVersion BuildNumber PlatformId CSDVersion) - (sb!win32:get-version-ex) - (declare (ignore PlatformId)) - (format nil (if (zerop (length CSDVersion)) "~A.~A.~A" "~A.~A.~A (~A)") - MajorVersion MinorVersion BuildNumber CSDVersion))))) + (multiple-value-bind (MajorVersion MinorVersion BuildNumber PlatformId CSDVersion) + (sb!win32:get-version-ex) + (declare (ignore PlatformId)) + (format nil (if (zerop (length CSDVersion)) "~A.~A.~A" "~A.~A.~A (~A)") + MajorVersion MinorVersion BuildNumber CSDVersion))))) ;;; Return user time, system time, and number of page faults. (defun get-system-info () Index: win32.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/win32.lisp,v retrieving revision 1.10 retrieving revision 1.11 diff -u -d -r1.10 -r1.11 --- win32.lisp 18 Sep 2006 11:28:07 -0000 1.10 +++ win32.lisp 20 Sep 2006 12:08:22 -0000 1.11 @@ -374,6 +374,8 @@ l)))))) ,@body))) +(defmacro make-system-buffer (x) + `(make-alien char #!+sb-unicode (ash ,x 1) #!-sb-unicode ,x)) ;;; FIXME: The various FOO-SYSCALL-BAR macros, and perhaps some other ;;; macros in this file, are only used in this file, and could be @@ -432,21 +434,21 @@ (defun get-folder-pathname (csidl) "http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp" - (with-alien ((apath (* char) (make-alien char (1+ max_path)))) + (with-alien ((apath (* char) (make-system-buffer (1+ max_path)))) (syscall (("SHGetFolderPath" 20 t) int handle int handle dword (* char)) (parse-native-namestring (concatenate 'string (cast-and-free apath) "\\")) 0 csidl 0 0 apath))) (defun sb!unix:posix-getcwd () - (with-alien ((apath (* char) (make-alien char (1+ max_path)))) + (with-alien ((apath (* char) (make-system-buffer (1+ max_path)))) (with-sysfun (afunc ("GetCurrentDirectory" 8 t) dword dword (* char)) (let ((ret (alien-funcall afunc (1+ max_path) apath))) (when (zerop ret) (win32-error "GetCurrentDirectory")) (when (> ret (1+ max_path)) (free-alien apath) - (setf apath (make-alien char ret)) + (setf apath (make-system-buffer ret)) (alien-funcall afunc ret apath)) (cast-and-free apath))))) @@ -462,13 +464,13 @@ (defun sb!unix::posix-getenv (name) (declare (type simple-string name)) - (with-alien ((aenv (* char) (make-alien char default-environment-length))) + (with-alien ((aenv (* char) (make-system-buffer default-environment-length))) (with-sysfun (afunc ("GetEnvironmentVariable" 12 t) dword system-string (* char) dword) (let ((ret (alien-funcall afunc name aenv default-environment-length))) (when (> ret default-environment-length) (free-alien aenv) - (setf aenv (make-alien char ret)) + (setf aenv (make-system-buffer ret)) (alien-funcall afunc name aenv ret)) (if (> ret 0) (cast-and-free aenv) @@ -557,7 +559,7 @@ ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/getcomputername.asp (declaim (ftype (function () simple-string) get-computer-name)) (defun get-computer-name () - (with-alien ((aname (* char) (make-alien char (1+ MAX_COMPUTERNAME_LENGTH))) + (with-alien ((aname (* char) (make-system-buffer (1+ MAX_COMPUTERNAME_LENGTH))) (length dword (1+ MAX_COMPUTERNAME_LENGTH))) (with-sysfun (afunc ("GetComputerName" 8 t) bool (* char) (* dword)) (when (zerop (alien-funcall afunc aname (addr length))) @@ -565,6 +567,6 @@ (unless (= err ERROR_BUFFER_OVERFLOW) (win32-error "GetComputerName" err)) (free-alien aname) - (setf aname (make-alien char length)) + (setf aname (make-system-buffer length)) (alien-funcall afunc aname (addr length)))) (cast-and-free aname)))) |