Commit a4a5e8fb authored by Juho Snellman's avatar Juho Snellman
Browse files

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
parent 447477e7
Loading
Loading
Loading
Loading
+3 −3
Original line number Original line Diff line number Diff line
@@ -43,9 +43,9 @@
        (when sbcl-homedir
        (when sbcl-homedir
          (probe-file (merge-pathnames sbcl-homedir "sbclrc"))))
          (probe-file (merge-pathnames sbcl-homedir "sbclrc"))))
      #!+win32
      #!+win32
      (merge-pathnames (sb!win32::get-folder-pathname
      (merge-pathnames "sbcl\\sbclrc"
                        sb!win32::csidl_common_appdata)
                       (sb!win32::get-folder-pathname
                       "\\sbcl\\sbclrc")
                        sb!win32::csidl_common_appdata))
      #!-win32
      #!-win32
      "/etc/sbclrc"))
      "/etc/sbclrc"))


+9 −7
Original line number Original line Diff line number Diff line
@@ -374,6 +374,8 @@
                               l))))))
                               l))))))
     ,@body)))
     ,@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
;;; FIXME: The various FOO-SYSCALL-BAR macros, and perhaps some other
;;; macros in this file, are only used in this file, and could be
;;; macros in this file, are only used in this file, and could be
@@ -432,21 +434,21 @@


(defun get-folder-pathname (csidl)
(defun get-folder-pathname (csidl)
  "http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp"
  "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))
    (syscall (("SHGetFolderPath" 20 t) int handle int handle dword (* char))
             (parse-native-namestring
             (parse-native-namestring
               (concatenate 'string (cast-and-free apath) "\\"))
               (concatenate 'string (cast-and-free apath) "\\"))
             0 csidl 0 0 apath)))
             0 csidl 0 0 apath)))


(defun sb!unix:posix-getcwd ()
(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))
    (with-sysfun (afunc ("GetCurrentDirectory" 8 t) dword dword (* char))
      (let ((ret (alien-funcall afunc (1+ max_path) apath)))
      (let ((ret (alien-funcall afunc (1+ max_path) apath)))
        (when (zerop ret)
        (when (zerop ret)
          (win32-error "GetCurrentDirectory"))
          (win32-error "GetCurrentDirectory"))
        (when (> ret (1+ max_path))
        (when (> ret (1+ max_path))
          (free-alien apath)
          (free-alien apath)
          (setf apath (make-alien char ret))
          (setf apath (make-system-buffer ret))
          (alien-funcall afunc ret apath))
          (alien-funcall afunc ret apath))
        (cast-and-free apath)))))
        (cast-and-free apath)))))


@@ -462,13 +464,13 @@


(defun sb!unix::posix-getenv (name)
(defun sb!unix::posix-getenv (name)
  (declare (type simple-string 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)
    (with-sysfun (afunc ("GetEnvironmentVariable" 12 t)
                        dword system-string (* char) dword)
                        dword system-string (* char) dword)
      (let ((ret (alien-funcall afunc name aenv default-environment-length)))
      (let ((ret (alien-funcall afunc name aenv default-environment-length)))
        (when (> ret default-environment-length)
        (when (> ret default-environment-length)
          (free-alien aenv)
          (free-alien aenv)
          (setf aenv (make-alien char ret))
          (setf aenv (make-system-buffer ret))
          (alien-funcall afunc name aenv ret))
          (alien-funcall afunc name aenv ret))
        (if (> ret 0)
        (if (> ret 0)
            (cast-and-free aenv)
            (cast-and-free aenv)
@@ -557,7 +559,7 @@
;; http://msdn.microsoft.com/library/en-us/sysinfo/base/getcomputername.asp
;; http://msdn.microsoft.com/library/en-us/sysinfo/base/getcomputername.asp
(declaim (ftype (function () simple-string) get-computer-name))
(declaim (ftype (function () simple-string) get-computer-name))
(defun 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)))
               (length dword (1+ MAX_COMPUTERNAME_LENGTH)))
    (with-sysfun (afunc ("GetComputerName" 8 t) bool (* char) (* dword))
    (with-sysfun (afunc ("GetComputerName" 8 t) bool (* char) (* dword))
      (when (zerop (alien-funcall afunc aname (addr length)))
      (when (zerop (alien-funcall afunc aname (addr length)))
@@ -565,6 +567,6 @@
          (unless (= err ERROR_BUFFER_OVERFLOW)
          (unless (= err ERROR_BUFFER_OVERFLOW)
            (win32-error "GetComputerName" err))
            (win32-error "GetComputerName" err))
          (free-alien aname)
          (free-alien aname)
          (setf aname (make-alien char length))
          (setf aname (make-system-buffer length))
          (alien-funcall afunc aname (addr length))))
          (alien-funcall afunc aname (addr length))))
      (cast-and-free aname))))
      (cast-and-free aname))))
+1 −1
Original line number Original line Diff line number Diff line
@@ -17,4 +17,4 @@
;;; checkins which aren't released. (And occasionally for internal
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
"0.9.16.40"
"0.9.16.41"
+5 −5

File changed.

Contains only whitespace changes.